From a3bbce395607768354e92f34d3db34a5c0c4d73e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Sep 2008 23:38:40 -0500 Subject: [PATCH 01/39] Add a couple of onlinline inline declarations --- core/sequences/sequences.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9be2db3fd7..e5c6b5ad99 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -739,10 +739,10 @@ PRIVATE> [ but-last ] [ peek ] bi ; : unclip-slice ( seq -- rest first ) - [ rest-slice ] [ first ] bi ; + [ rest-slice ] [ first ] bi ; inline : unclip-last-slice ( seq -- butfirst last ) - [ but-last-slice ] [ peek ] bi ; + [ but-last-slice ] [ peek ] bi ; inline : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; From 6a1e6d3c086a8f6e9db0e6fc881c08d3858754bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 01:45:16 -0500 Subject: [PATCH 02/39] Fix dispatch bug found by mnestic --- core/kernel/kernel-tests.factor | 6 ++++-- core/sequences/sequences.factor | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 5cb4abc2e9..8a51d45447 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,6 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations -continuations prettyprint io.streams.string debugger assocs ; +continuations prettyprint io.streams.string debugger assocs +sequences.private ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -118,7 +119,8 @@ IN: kernel.tests [ total-failure-1 ] must-fail -! From combinators.lib [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test [ [ sq ] tri@ ] must-infer + +[ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index df79069898..dbb24c3168 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -74,7 +74,7 @@ INSTANCE: immutable-sequence sequence : set-array-nth ( elt n array -- ) swap 2 fixnum+fast set-slot ; inline -: dispatch ( n array -- ) array-nth (call) ; +: dispatch ( n array -- ) array-nth call ; GENERIC: resize ( n seq -- newseq ) flushable From 079cbbfb77889a4240646ecde7239de4cc1bf4ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 03:17:22 -0500 Subject: [PATCH 03/39] Fix generation of 32-bit images on a 64-bit machine --- basis/bootstrap/image/image.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9c99ed5cdb..edfd82dae2 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -280,7 +280,7 @@ M: f ' [ [ { - [ hashcode , ] + [ hashcode , ] [ name>> , ] [ vocabulary>> , ] [ def>> , ] From 9e82c69489d7e58efa9b14105d83bea97a289147 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 16:57:53 -0500 Subject: [PATCH 04/39] clean up random --- basis/random/random.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index 0a421288d5..515c464a5a 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -36,9 +36,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; : random ( seq -- elt ) [ f ] [ [ - length dup log2 7 + 8 /i 1+ random-bytes - [ length 3 shift 2^ ] [ byte-array>bignum ] bi - swap / * >integer + length dup log2 7 + 8 /i 1+ + [ random-bytes byte-array>bignum ] + [ 3 shift 2^ ] bi / * >integer ] keep nth ] if-empty ; From 5d474e185903a032ce4ad4bb2ea31146100ca119 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 18:22:50 -0500 Subject: [PATCH 05/39] Clean up mandelbrot --- extra/benchmark/mandel/colors/colors.factor | 2 +- extra/benchmark/mandel/mandel.factor | 43 +++++++++------------ extra/benchmark/mandel/params/params.factor | 12 +++--- 3 files changed, 26 insertions(+), 31 deletions(-) diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor index 848fbae01e..7bbb25a47d 100644 --- a/extra/benchmark/mandel/colors/colors.factor +++ b/extra/benchmark/mandel/colors/colors.factor @@ -16,4 +16,4 @@ IN: benchmark.mandel.colors ] with map ; : color-map ( -- map ) - nb-iter max-color min ; foldable + max-iterations max-color min ; foldable diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index a40b123ed3..e87765499b 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,16 +1,11 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math math.functions math.order -math.parser sequences locals byte-arrays byte-vectors io.files -io.encodings.binary benchmark.mandel.params +math.parser sequences byte-arrays byte-vectors io.files +io.encodings.binary fry namespaces benchmark.mandel.params benchmark.mandel.colors ; IN: benchmark.mandel -: iter ( c z nb-iter -- x ) - dup 0 <= [ 2nip ] [ - over absq 4.0 >= [ 2nip ] [ - >r sq dupd + r> 1- iter - ] if - ] if ; inline recursive - : x-inc width 200000 zoom-fact * / ; inline : y-inc height 150000 zoom-fact * / ; inline @@ -19,27 +14,27 @@ IN: benchmark.mandel [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi* rect> ; inline -:: render ( accum -- ) - height [ - width swap [ - c C{ 0.0 0.0 } nb-iter iter dup zero? - [ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if - accum push-all - ] curry each - ] each ; inline +: count-iterations ( z max-iterations step-quot test-quot -- #iters ) + '[ drop @ dup @ ] find-last-integer nip ; inline -:: ppm-header ( accum -- ) - "P6\n" accum push-all - width number>string accum push-all - " " accum push-all - height number>string accum push-all - "\n255\n" accum push-all ; inline +: pixel ( c -- iterations ) + [ C{ 0.0 0.0 } max-iterations ] dip + '[ sq , + ] [ absq 4.0 >= ] count-iterations ; inline + +: color ( iterations -- color ) + [ color-map [ length mod ] keep nth ] [ B{ 0 0 0 } ] if* ; inline + +: render ( -- ) + height [ width swap '[ , c pixel color % ] each ] each ; inline + +: ppm-header ( -- ) + "P6\n" % width # " " % height # "\n255\n" % ; inline : buf-size ( -- n ) width height * 3 * 100 + ; inline : mandel ( -- data ) buf-size - [ ppm-header ] [ render ] [ B{ } like ] tri ; + [ building [ ppm-header render ] with-variable ] [ B{ } like ] bi ; : mandel-main ( -- ) mandel "mandel.ppm" temp-file binary set-file-contents ; diff --git a/extra/benchmark/mandel/params/params.factor b/extra/benchmark/mandel/params/params.factor index 3fcfe1d3ef..c40d3c1f2d 100644 --- a/extra/benchmark/mandel/params/params.factor +++ b/extra/benchmark/mandel/params/params.factor @@ -1,8 +1,8 @@ IN: benchmark.mandel.params -: max-color 360 ; inline -: zoom-fact 0.8 ; inline -: width 640 ; inline -: height 480 ; inline -: nb-iter 40 ; inline -: center -0.65 ; inline +: max-color 360 ; inline +: zoom-fact 0.8 ; inline +: width 640 ; inline +: height 480 ; inline +: max-iterations 40 ; inline +: center -0.65 ; inline From d97ff8d94dd8bdab4e64b9baae7348fcc286586a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 19:16:18 -0500 Subject: [PATCH 06/39] clean up count-end --- basis/base64/base64.factor | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 747cfa1128..7097de6c6e 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences io.binary splitting grouping ; +USING: kernel math sequences io.binary splitting grouping +accessors ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline +: count-end ( seq quot -- n ) + trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -21,13 +22,16 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; + be> 4 [ + -6 * shift HEX: 3f bitand ch>base64 + ] with B{ } map-as ; : decode4 ( str -- str ) 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi + head-slice 4 CHAR: = pad-right ; PRIVATE> @@ -42,5 +46,5 @@ PRIVATE> : base64> ( base64 -- str ) #! input length must be a multiple of 4 [ 4 [ decode4 ] map concat ] - [ [ CHAR: = = not ] count-end ] + [ [ CHAR: = = ] count-end ] bi head* ; From 44f53de16496395a16862da780792a0fecf10316 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 20:07:00 -0500 Subject: [PATCH 07/39] Move make to its own vocabulary, remove fry _ feature --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 2 +- basis/alien/structs/fields/fields.factor | 2 +- basis/bootstrap/image/image.factor | 2 +- basis/cocoa/messages/messages.factor | 11 +++-- basis/cocoa/subclassing/subclassing.factor | 2 +- basis/cocoa/views/views.factor | 2 +- basis/compiler/generator/fixup/fixup.factor | 2 +- basis/compiler/generator/generator.factor | 16 +++---- .../generator/registers/registers.factor | 6 +-- .../tree/cleanup/cleanup-tests.factor | 21 ++++++++++ basis/compiler/tree/debugger/debugger.factor | 2 +- .../tree/finalization/finalization.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 6 +-- basis/cpu/architecture/architecture.factor | 4 +- .../cpu/x86/architecture/architecture.factor | 2 +- basis/cpu/x86/assembler/assembler.factor | 2 +- basis/debugger/debugger.factor | 12 +++--- basis/debugger/threads/threads.factor | 2 +- basis/delegate/delegate.factor | 2 +- basis/documents/documents.factor | 2 +- basis/fry/fry-docs.factor | 23 ---------- basis/fry/fry-tests.factor | 14 +++---- basis/fry/fry.factor | 42 +++++++------------ basis/furnace/chloe-tags/chloe-tags.factor | 2 +- basis/generalizations/generalizations.factor | 4 +- basis/help/help.factor | 4 +- basis/help/lint/lint.factor | 4 +- basis/help/markup/markup.factor | 2 +- basis/help/topics/topics.factor | 2 +- basis/html/forms/forms.factor | 2 +- basis/http/http.factor | 2 +- basis/interval-maps/interval-maps.factor | 2 +- basis/io/servers/packet/datagram.factor | 2 +- basis/io/unix/backend/backend.factor | 2 +- basis/locals/locals.factor | 17 ++++---- basis/macros/expander/expander.factor | 5 ++- basis/match/match.factor | 4 +- .../partial-dispatch/partial-dispatch.factor | 2 +- basis/memoize/memoize.factor | 2 +- basis/mime-types/mime-types.factor | 4 +- basis/peg/parsers/parsers.factor | 7 ++-- basis/peg/peg.factor | 12 +++--- .../nodes/collision/collision.factor | 2 +- basis/prettyprint/backend/backend.factor | 4 +- basis/prettyprint/prettyprint.factor | 6 +-- basis/prettyprint/sections/sections.factor | 2 +- basis/stack-checker/branches/branches.factor | 4 +- .../transforms/transforms.factor | 2 +- basis/summary/summary.factor | 2 +- basis/tools/deploy/backend/backend.factor | 8 ++-- basis/tools/deploy/macosx/macosx.factor | 2 +- basis/tools/disassembler/disassembler.factor | 6 +-- basis/tools/vocabs/vocabs.factor | 8 ++-- basis/tools/walker/walker.factor | 2 +- basis/ui/commands/commands-docs.factor | 2 +- basis/ui/commands/commands.factor | 4 +- basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/gadgets.factor | 7 ++-- basis/ui/gadgets/grids/grids.factor | 2 +- basis/ui/gadgets/labels/labels.factor | 5 +-- basis/ui/gestures/gestures.factor | 6 +-- basis/ui/operations/operations.factor | 2 +- basis/ui/tools/walker/walker.factor | 2 +- basis/ui/traverse/traverse.factor | 4 +- basis/ui/ui-docs.factor | 7 ---- basis/ui/ui.factor | 2 +- basis/unicode/case/case.factor | 2 +- basis/unicode/normalize/normalize.factor | 2 +- basis/unicode/syntax/syntax.factor | 6 +-- basis/urls/urls.factor | 2 +- core/classes/classes.factor | 4 +- core/classes/predicate/predicate.factor | 4 +- core/classes/tuple/parser/parser.factor | 2 +- core/classes/tuple/tuple.factor | 8 ++-- core/compiler/errors/errors.factor | 2 +- core/continuations/continuations.factor | 2 +- core/destructors/destructors.factor | 2 +- core/effects/effects.factor | 2 +- core/generic/generic.factor | 2 +- core/generic/math/math.factor | 4 +- core/generic/standard/engines/tag/tag.factor | 4 +- .../standard/engines/tuple/tuple.factor | 2 +- core/generic/standard/standard.factor | 2 +- core/io/io.factor | 2 +- core/io/streams/c/c.factor | 2 +- core/math/parser/parser-docs.factor | 2 +- core/math/parser/parser.factor | 4 +- core/namespaces/namespaces-docs.factor | 25 ----------- core/namespaces/namespaces.factor | 31 ++------------ core/slots/slots.factor | 6 +-- core/splitting/splitting.factor | 2 +- core/strings/parser/parser.factor | 2 +- core/vocabs/loader/loader.factor | 4 +- extra/monads/monads.factor | 16 +++---- extra/ui/gadgets/tabs/tabs.factor | 2 +- extra/webapps/wiki/wiki.factor | 9 +--- .../concatenative/concatenative.factor | 16 ++++--- 98 files changed, 227 insertions(+), 305 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 71c3fd6ff2..94472e8261 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces libc cpu.architecture ; +sequences math kernel namespaces make libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index f44941d88f..6a88441be9 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private libc math -namespaces parser sequences strings words assocs splitting +namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary accessors combinators effects continuations ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 5273c2c7ba..19e5b8c326 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel kernel.private math namespaces -sequences strings words effects combinators alien.c-types ; +make sequences strings words effects combinators alien.c-types ; IN: alien.structs.fields TUPLE: field-spec name offset type reader writer ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index edfd82dae2..9284728a7a 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic assocs hashtables assocs -hashtables.private io kernel kernel.private math namespaces +hashtables.private io kernel kernel.private math namespaces make parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts splitting grouping growable classes classes.builtin classes.tuple diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 7be649416c..7977485b02 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.strings -arrays assocs combinators compiler kernel -math namespaces parser prettyprint prettyprint.sections -quotations sequences strings words cocoa.runtime io macros -memoize debugger io.encodings.ascii effects compiler.generator -libc libc.private ; +USING: accessors alien alien.c-types alien.strings arrays assocs +combinators compiler kernel math namespaces make parser +prettyprint prettyprint.sections quotations sequences strings +words cocoa.runtime io macros memoize debugger +io.encodings.ascii effects compiler.generator libc libc.private ; IN: cocoa.messages : make-sender ( method function -- quot ) diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 1ee39c35d5..3f8e709df0 100755 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings arrays assocs combinators compiler hashtables kernel libc math namespaces parser sequences words cocoa.messages cocoa.runtime compiler.units io.encodings.ascii generalizations -continuations ; +continuations make ; IN: cocoa.subclassing : init-method ( method -- sel imp types ) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 8bfbe330b2..d03688b2be 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel math namespaces cocoa +USING: alien.c-types arrays kernel math namespaces make cocoa cocoa.messages cocoa.classes cocoa.types sequences continuations ; IN: cocoa.views diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index 5a3337fb32..ecc88a7a5e 100755 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays generic assocs hashtables io.binary -kernel kernel.private math namespaces sequences words +kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts system combinators math.bitwise words.private cpu.architecture math.order accessors growable ; diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index da120ce432..939d6e2276 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -1,15 +1,15 @@ - ! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes combinators cpu.architecture effects generic hashtables io kernel -kernel.private layouts math math.parser namespaces prettyprint -quotations sequences system threads words vectors sets deques -continuations.private summary alien alien.c-types +kernel.private layouts math math.parser namespaces make +prettyprint quotations sequences system threads words vectors +sets deques continuations.private summary alien alien.c-types alien.structs alien.strings alien.arrays libc compiler.errors -stack-checker.inlining -compiler.tree compiler.tree.builder compiler.tree.combinators -compiler.tree.propagation.info compiler.generator.fixup -compiler.generator.registers compiler.generator.iterator ; +stack-checker.inlining compiler.tree compiler.tree.builder +compiler.tree.combinators compiler.tree.propagation.info +compiler.generator.fixup compiler.generator.registers +compiler.generator.iterator ; IN: compiler.generator SYMBOL: compile-queue diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index e909db3f83..76d3c32594 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes classes.private classes.algebra -combinators hashtables kernel layouts math namespaces quotations -sequences system vectors words effects alien byte-arrays -accessors sets math.order cpu.architecture +combinators hashtables kernel layouts math namespaces make +quotations sequences system vectors words effects alien +byte-arrays accessors sets math.order cpu.architecture compiler.generator.fixup ; IN: compiler.generator.registers diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index bb30cda685..644b834117 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -457,3 +457,24 @@ cell-bits 32 = [ [ [ >r "A" throw r> ] [ "B" throw ] if ] cleaned-up-tree drop ] unit-test + +! Regression from benchmark.nsieve +: chicken-fingers ( i seq -- ) + 2dup < [ + 2drop + ] [ + chicken-fingers + ] if ; inline recursive + +: buffalo-wings ( i seq -- ) + 2dup < [ + 2dup chicken-fingers + >r 1+ r> buffalo-wings + ] [ + 2drop + ] if ; inline recursive + +[ t ] [ + [ 2 swap >fixnum buffalo-wings ] + { <-integer-fixnum +-integer-fixnum } inlined? +] unit-test diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index db742197a5..01b91b1613 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs fry match accessors namespaces effects +USING: kernel assocs fry match accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.sections math words combinators io sorting hints diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 5aaeed360a..540119f709 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays accessors sequences sequences.private words -fry namespaces math math.order memoize classes.builtin +fry namespaces make math math.order memoize classes.builtin classes.tuple.private slots.private combinators layouts byte-arrays alien.accessors compiler.intrinsics diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index f14dba6433..bb21391f0a 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax kernel -math sequences namespaces assocs init accessors continuations -combinators core-foundation core-foundation.run-loop -io.encodings.utf8 destructors ; +math sequences namespaces make assocs init accessors +continuations combinators core-foundation +core-foundation.run-loop io.encodings.utf8 destructors ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index fc11e0a731..432e748cbf 100755 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory -namespaces sequences layouts system hashtables classes alien -byte-arrays combinators words sets ; +namespaces make sequences layouts system hashtables classes +alien byte-arrays combinators words sets ; IN: cpu.architecture ! Register classes diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 69bc685364..13524aecc4 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private -math memory namespaces sequences words compiler.generator +math memory namespaces make sequences words compiler.generator compiler.generator.registers compiler.generator.fixup system layouts combinators compiler.constants math.order ; IN: cpu.x86.architecture diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index d9c25d8492..f557bb4adc 100755 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays compiler.generator.fixup io.binary kernel -combinators kernel.private math namespaces sequences +combinators kernel.private math namespaces make sequences words system layouts math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 4d01567131..b7fd34c5be 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slots arrays definitions generic hashtables summary io -kernel math namespaces prettyprint prettyprint.config sequences -assocs sequences.private strings io.styles io.files vectors -words system splitting math.parser classes.tuple continuations -continuations.private combinators generic.math classes.builtin -classes compiler.units generic.standard vocabs init -kernel.private io.encodings accessors math.order +kernel math namespaces make prettyprint prettyprint.config +sequences assocs sequences.private strings io.styles io.files +vectors words system splitting math.parser classes.tuple +continuations continuations.private combinators generic.math +classes.builtin classes compiler.units generic.standard vocabs +init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer compiler.errors generic.parser strings.parser ; diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor index 7bb240859e..27ffdc629b 100644 --- a/basis/debugger/threads/threads.factor +++ b/basis/debugger/threads/threads.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors debugger continuations threads threads.private -io io.styles prettyprint kernel math.parser namespaces ; +io io.styles prettyprint kernel math.parser namespaces make ; IN: debugger.threads : error-in-thread. ( thread -- ) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index fd9b9977e1..45cc214792 100755 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions -prettyprint math hashtables sets macros namespaces ; +prettyprint math hashtables sets macros namespaces make ; IN: delegate : protocol-words ( protocol -- words ) diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index cac7574e35..54bc85284a 100755 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays io kernel math models namespaces +USING: accessors arrays io kernel math models namespaces make sequences strings splitting combinators unicode.categories math.order ; IN: documents diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 05cde62c1f..4f33a6892a 100755 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -7,9 +7,6 @@ HELP: , HELP: @ { $description "Fry specifier. Splices a quotation into the fried quotation." } ; -HELP: _ -{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ; - HELP: fry { $values { "quot" quotation } { "quot'" quotation } } { $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." } @@ -52,25 +49,11 @@ $nl "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? dup 5 ? ] map" } -"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:" -{ $code - "{ 10 20 30 } 1 '[ , _ / ] map" - "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map" - "{ 10 20 30 } 1 [ swap / ] curry map" - "{ 10 20 30 } [ 1 swap / ] map" -} -"For any quotation body " { $snippet "X" } ", the following two are equivalent:" -{ $code - "[ [ X ] dip ]" - "'[ X _ ]" -} "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ , ] ;" } } { { $link slip } { $snippet ": slip '[ @ , ] call ;" } } - { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } } { { $link curry } { $snippet ": curry '[ , @ ] ;" } } - { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } } } ; @@ -85,11 +68,6 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy" { $code "'[ 3 , + 4 , / ]" "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" -} -"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:" -{ $code - "'[ , 2 + , * _ / ]" - "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]" } ; ARTICLE: "fry.limitations" "Fried quotation limitations" @@ -103,7 +81,6 @@ $nl "Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":" { $subsection , } { $subsection @ } -{ $subsection _ } "When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left." { $subsection "fry.examples" } { $subsection "fry.philosophy" } diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 6d6abba23c..b8cdbc8cd7 100755 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -19,29 +19,25 @@ sequences ; [ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test [ 1/2 ] [ - 1 '[ , _ / ] 2 swap call + 1 '[ [ , ] dip / ] 2 swap call ] unit-test [ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ - 1 '[ , _ _ 3array ] + 1 '[ [ , ] 2dip 3array ] { "a" "b" "c" } { "A" "B" "C" } rot 2map ] unit-test [ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ - '[ 1 _ 2array ] + '[ [ 1 ] dip 2array ] { "a" "b" "c" } swap map ] unit-test -[ 1 2 ] [ - 1 2 '[ _ , ] call -] unit-test - [ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ - 1 2 '[ , _ , 3array ] + 1 2 '[ [ , ] dip , 3array ] { "a" "b" "c" } swap map ] unit-test -: funny-dip '[ @ _ ] call ; inline +: funny-dip '[ [ @ ] dip ] call ; inline [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 2b84d58d06..af7da07d27 100755 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting math -quotations arrays namespaces qualified ; -QUALIFIED: namespaces +quotations arrays make qualified words ; +QUALIFIED: make IN: fry : , ( -- * ) "Only valid inside a fry" throw ; : @ ( -- * ) "Only valid inside a fry" throw ; -: _ ( -- * ) "Only valid inside a fry" throw ; + +r suffix r> (shallow-fry) ] } case @@ -35,32 +34,23 @@ DEFER: shallow-fry : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; -: deep-fry ( quot -- quot ) - { _ } last-split1 dup [ - shallow-fry [ >r ] rot - deep-fry [ [ dip ] curry r> compose ] 4array concat - ] [ - drop shallow-fry - ] if ; +PREDICATE: fry-specifier < word { , make:, @ } memq? ; -: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ; +GENERIC: count-inputs ( quot -- n ) + +M: callable count-inputs [ count-inputs ] sigma ; +M: fry-specifier count-inputs drop 1 ; +M: object count-inputs drop 0 ; + +PRIVATE> -: count-inputs ( quot -- n ) - [ - { - { [ dup callable? ] [ count-inputs ] } - { [ dup fry-specifier? ] [ drop 1 ] } - [ drop 0 ] - } cond - ] map sum ; - : fry ( quot -- quot' ) [ [ dup callable? [ [ count-inputs \ , % ] [ fry % ] bi - ] [ namespaces:, ] if + ] [ make:, ] if ] each - ] [ ] make deep-fry ; + ] [ ] make shallow-fry ; : '[ \ ] parse-until fry over push-all ; parsing diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 8822bca519..e4286e3bdf 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -56,7 +56,7 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; : compile-link-attrs ( tag -- ) #! Side-effects current namespace. - attrs>> '[ [ , _ link-attr ] each-responder ] [code] ; + attrs>> '[ [ [ , ] dip link-attr ] each-responder ] [code] ; : a-start-tag ( tag -- ) [ compile-link-attrs ] [ compile-a-url ] bi diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index c97e9c7b91..a3c86b6683 100755 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -14,8 +14,8 @@ MACRO: narray ( n -- quot ) MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ [ '[ , _ nth-unsafe ] ] map ] - [ 1- '[ , _ bounds-check 2drop ] ] + [ [ '[ [ , ] dip nth-unsafe ] ] map ] + [ 1- '[ [ , ] dip bounds-check 2drop ] ] bi prefix '[ , cleave ] ] if ; diff --git a/basis/help/help.factor b/basis/help/help.factor index b2fff22372..686578f1b6 100755 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays io io.styles kernel namespaces parser -prettyprint sequences words assocs definitions generic +USING: accessors arrays io io.styles kernel namespaces make +parser prettyprint sequences words assocs definitions generic quotations effects slots continuations classes.tuple debugger combinators vocabs help.stylesheet help.topics help.crossref help.markup sorting classes vocabs.loader ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 4ad9067457..facaa8a010 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors sequences parser kernel help help.markup -help.topics words strings classes tools.vocabs namespaces io -io.streams.string prettyprint definitions arrays vectors +help.topics words strings classes tools.vocabs namespaces make +io io.streams.string prettyprint definitions arrays vectors combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 3077a93ed4..b5e074b598 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions generic io kernel assocs -hashtables namespaces parser prettyprint sequences strings +hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots vocabs help.stylesheet help.topics vocabs.loader alias ; IN: help.markup diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index cdb32b18ee..e6b19d5baa 100755 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license.x USING: accessors arrays definitions generic assocs -io kernel namespaces prettyprint prettyprint.sections +io kernel namespaces make prettyprint prettyprint.sections sequences words summary classes strings vocabs ; IN: help.topics diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 911e545f87..34d6a4dcb2 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -103,4 +103,4 @@ C: validation-error swap set-value ; : validate-values ( assoc validators -- assoc' ) - swap '[ dup , at _ validate-value ] assoc-each ; + swap '[ [ dup , at ] dip validate-value ] assoc-each ; diff --git a/basis/http/http.factor b/basis/http/http.factor index 03cca05ff3..d03d6c2203 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -196,7 +196,7 @@ M: response clone [ clone ] change-cookies ; : get-cookie ( request/response name -- cookie/f ) - [ cookies>> ] dip '[ , _ name>> = ] find nip ; + [ cookies>> ] dip '[ [ , ] dip name>> = ] find nip ; : delete-cookie ( request/response name -- ) over cookies>> [ get-cookie ] dip delete ; diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index a62855d78f..99da00ceab 100755 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences arrays accessors grouping math.order -sorting binary-search math assocs locals namespaces ; +sorting binary-search math assocs locals namespaces make ; IN: interval-maps TUPLE: interval-map array ; diff --git a/basis/io/servers/packet/datagram.factor b/basis/io/servers/packet/datagram.factor index 03596ee43c..758e85a777 100644 --- a/basis/io/servers/packet/datagram.factor +++ b/basis/io/servers/packet/datagram.factor @@ -18,4 +18,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline + '[ [ [ , ] dip spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index aa27b21d98..0e9139f431 100755 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types generic assocs kernel kernel.private math io.ports sequences strings structs sbufs threads unix vectors io.buffers io.backend io.encodings math.parser -continuations system libc qualified namespaces io.timeouts +continuations system libc qualified namespaces make io.timeouts io.encodings.utf8 destructors accessors summary combinators locals ; QUALIFIED: io diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index af5f6834bc..bfc92ee9e2 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences sequences.private assocs math - vectors strings classes.tuple generalizations - parser words quotations debugger macros arrays macros splitting - combinators prettyprint.backend definitions prettyprint - hashtables prettyprint.sections sets sequences.private effects - effects.parser generic generic.parser compiler.units accessors - locals.backend memoize macros.expander lexer - stack-checker.known-words ; - +USING: kernel namespaces make sequences sequences.private assocs +math vectors strings classes.tuple generalizations parser words +quotations debugger macros arrays macros splitting combinators +prettyprint.backend definitions prettyprint hashtables +prettyprint.sections sets sequences.private effects +effects.parser generic generic.parser compiler.units accessors +locals.backend memoize macros.expander lexer +stack-checker.known-words ; IN: locals ! Inspired by diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 0a1703de58..d766430810 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces quotations accessors words -continuations vectors effects math stack-checker.transforms ; +USING: kernel sequences namespaces make quotations accessors +words continuations vectors effects math +stack-checker.transforms ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) diff --git a/basis/match/match.factor b/basis/match/match.factor index 0ae285d20d..c546555d07 100755 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Based on pattern matching code from Paul Graham's book 'On Lisp'. -USING: parser lexer kernel words namespaces sequences classes.tuple -combinators macros assocs math effects ; +USING: parser lexer kernel words namespaces make sequences +classes.tuple combinators macros assocs math effects ; IN: match SYMBOL: _ diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index baa5558f7f..6def4966a2 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private words -sequences parser namespaces assocs quotations arrays locals +sequences parser namespaces make assocs quotations arrays locals generic generic.math hashtables effects compiler.units ; IN: math.partial-dispatch diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 4b1a4a67d5..1c31156311 100755 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel hashtables sequences arrays words namespaces +USING: kernel hashtables sequences arrays words namespaces make parser math assocs effects definitions quotations summary accessors ; IN: memoize diff --git a/basis/mime-types/mime-types.factor b/basis/mime-types/mime-types.factor index 9489da8149..42b8f2e739 100755 --- a/basis/mime-types/mime-types.factor +++ b/basis/mime-types/mime-types.factor @@ -16,7 +16,9 @@ MEMO: mime-db ( -- seq ) } ; MEMO: mime-types ( -- assoc ) - [ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc + [ + mime-db [ unclip '[ [ , ] dip set ] each ] each + ] H{ } make-assoc nonstandard-mime-types assoc-union ; : mime-type ( filename -- mime-type ) diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 93de40d672..5739482093 100755 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays math.parser accessors - unicode.categories sequences.deep peg peg.private - peg.search math.ranges words ; +USING: kernel sequences strings namespaces make math assocs +shuffle vectors arrays math.parser accessors unicode.categories +sequences.deep peg peg.private peg.search math.ranges words ; IN: peg.parsers TUPLE: just-parser p1 ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 9ef1ac658e..e90a4c60b6 100755 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences strings fry namespaces math assocs shuffle debugger io - vectors arrays math.parser math.order vectors combinators - classes sets unicode.categories compiler.units parser - words quotations effects memoize accessors locals effects splitting - combinators.short-circuit combinators.short-circuit.smart - generalizations ; +USING: kernel sequences strings fry namespaces make math assocs +shuffle debugger io vectors arrays math.parser math.order +vectors combinators classes sets unicode.categories +compiler.units parser words quotations effects memoize accessors +locals effects splitting combinators.short-circuit +combinators.short-circuit.smart generalizations ; IN: peg USE: prettyprint diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor index 83003e5c47..741e3d067a 100644 --- a/basis/persistent/hashtables/nodes/collision/collision.factor +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -8,7 +8,7 @@ persistent.hashtables.nodes.leaf ; IN: persistent.hashtables.nodes.collision : find-index ( key hashcode collision-node -- n leaf-node ) - leaves>> -rot '[ , , _ matching-key? ] find ; inline + leaves>> -rot '[ [ , , ] dip matching-key? ] find ; inline M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node ) key hashcode collision-node find-index nip ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index c2fd94e5cf..f8445c7783 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays byte-vectors generic -hashtables io assocs kernel math namespaces sequences strings -sbufs io.styles vectors words prettyprint.config +hashtables io assocs kernel math namespaces make sequences +strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects classes.tuple math.order classes.tuple.private classes combinators colors ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 3b9d034378..149ecde447 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -1,15 +1,13 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. - -USING: arrays generic generic.standard assocs io kernel -math namespaces sequences strings io.styles io.streams.string +USING: arrays generic generic.standard assocs io kernel math +namespaces make sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton combinators quotations sets accessors colors ; - IN: prettyprint : make-pprint ( obj quot -- block in use ) diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 13c86ea994..a629ca6fff 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel math assocs -namespaces sequences strings io.styles vectors words +namespaces make sequences strings io.styles vectors words prettyprint.config splitting classes continuations io.streams.nested accessors sets ; IN: prettyprint.sections diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 4685483103..651b8d1626 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -22,7 +22,7 @@ SYMBOL: +bottom+ : phi-inputs ( max-d-in pairs -- newseq ) dup empty? [ nip ] [ - swap '[ , _ first2 unify-inputs ] map + swap '[ [ , ] dip first2 unify-inputs ] map pad-with-bottom ] if ; @@ -50,7 +50,7 @@ SYMBOL: quotations ] if-empty ; : branch-variable ( seq symbol -- seq ) - '[ , _ at ] map ; + '[ [ , ] dip at ] map ; : active-variable ( seq symbol -- seq ) [ [ terminated? over at [ drop f ] when ] map ] dip diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index d60565e849..e64795c5df 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel words sequences generic math -namespaces quotations assocs combinators classes.tuple +namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations stack-checker.backend stack-checker.state stack-checker.visitor diff --git a/basis/summary/summary.factor b/basis/summary/summary.factor index 5da6599c63..ea2c19fd6d 100644 --- a/basis/summary/summary.factor +++ b/basis/summary/summary.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes sequences splitting kernel namespaces -words math math.parser io.styles prettyprint assocs ; +make words math math.parser io.styles prettyprint assocs ; IN: summary GENERIC: summary ( object -- string ) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index ae4f6a8d62..324adcaad2 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces continuations.private kernel.private init +USING: namespaces make continuations.private kernel.private init assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes summary layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.files io.backend -quotations io.launcher words.private tools.deploy.config -bootstrap.image io.encodings.utf8 destructors accessors ; +debugger io.streams.c io.files io.backend quotations io.launcher +words.private tools.deploy.config bootstrap.image +io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name extension -- vm ) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index d38b40db4b..ee60ce3982 100755 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel namespaces sequences +USING: io io.files kernel namespaces make sequences system tools.deploy.backend tools.deploy.config assocs hashtables prettyprint io.unix.backend cocoa io.encodings.utf8 io.backend cocoa.application cocoa.classes cocoa.plists diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 887fd1b6d7..dabdaaaa7c 100755 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax -io.launcher system assocs arrays sequences namespaces qualified -system math compiler.generator.fixup io.encodings.ascii -accessors generic tr ; +io.launcher system assocs arrays sequences namespaces make +qualified system math compiler.generator.fixup +io.encodings.ascii accessors generic tr ; IN: tools.disassembler : in-file ( -- path ) "gdb-in.txt" temp-file ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 1c7e8d28d2..732a6635b7 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io io.styles io.files io.encodings.utf8 -vocabs.loader vocabs sequences namespaces math.parser arrays -hashtables assocs memoize summary sorting splitting combinators -source-files debugger continuations compiler.errors init -checksums checksums.crc32 sets accessors ; +vocabs.loader vocabs sequences namespaces make math.parser +arrays hashtables assocs memoize summary sorting splitting +combinators source-files debugger continuations compiler.errors +init checksums checksums.crc32 sets accessors ; IN: tools.vocabs : vocab-tests-file ( vocab -- path ) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index c1073eda8c..9775bdff81 100755 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.filter arrays accessors -generic generic.standard definitions ; +generic generic.standard definitions make ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor index 804236dadc..25312ad868 100644 --- a/basis/ui/commands/commands-docs.factor +++ b/basis/ui/commands/commands-docs.factor @@ -1,5 +1,5 @@ USING: accessors ui.gestures help.markup help.syntax strings kernel -hashtables quotations words classes sequences namespaces +hashtables quotations words classes sequences namespaces make arrays assocs ; IN: ui.commands diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index 2677c496ec..b45e2e4004 100755 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel sequences strings -math assocs words generic namespaces assocs quotations splitting -ui.gestures unicode.case unicode.categories tr ; +math assocs words generic namespaces make assocs quotations +splitting ui.gestures unicode.case unicode.categories tr ; IN: ui.commands SYMBOL: +nullary+ diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 8142297318..888716b364 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays documents io kernel math models -namespaces opengl opengl.gl sequences strings io.styles +namespaces make opengl opengl.gl sequences strings io.styles math.vectors sorting colors combinators assocs math.order ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 15850ae357..05764d5b84 100755 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel models math namespaces - sequences quotations math.vectors combinators sorting - binary-search vectors dlists deques models threads - concurrency.flags math.order math.geometry.rect ; - +make sequences quotations math.vectors combinators sorting +binary-search vectors dlists deques models threads +concurrency.flags math.order math.geometry.rect ; IN: ui.gadgets SYMBOL: ui-notify-flag diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 42e8cfdfdf..f14ccf1cca 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math namespaces sequences words io +USING: arrays kernel math namespaces make sequences words io io.streams.string math.vectors ui.gadgets columns accessors math.geometry.rect ; IN: ui.gadgets.grids diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index ed951824b8..f27b9898a1 100755 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables io kernel math namespaces -opengl sequences strings splitting -ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors -models ; +make opengl sequences strings splitting ui.gadgets +ui.gadgets.tracks ui.gadgets.theme ui.render colors models ; IN: ui.gadgets.labels ! A label gadget draws a string. diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 1170ea3fd1..a1c6adac6e 100755 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math models namespaces -sequences words strings system hashtables math.parser -math.vectors classes.tuple classes ui.gadgets boxes -calendar alarms symbols combinators sets columns ; +make sequences words strings system hashtables math.parser +math.vectors classes.tuple classes ui.gadgets boxes calendar +alarms symbols combinators sets columns ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index 8b4817dcac..3e0b36486e 100755 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel ui.commands -ui.gestures sequences strings math words generic namespaces +ui.gestures sequences strings math words generic namespaces make hashtables help.markup quotations assocs ; IN: ui.operations diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 51091c576d..7bc42ea676 100755 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: accessors kernel concurrency.messaging inspector ui.tools.listener ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets models models.filter ui.tools.workspace ui.gestures -ui.gadgets.labels ui threads namespaces tools.walker assocs +ui.gadgets.labels ui threads namespaces make tools.walker assocs combinators ; IN: ui.tools.walker diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 440f6487c2..eadd110fe7 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces sequences kernel math arrays io ui.gadgets -generic combinators ; +USING: accessors namespaces make sequences kernel math arrays io +ui.gadgets generic combinators ; IN: ui.traverse TUPLE: node value children ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index e086b7ebae..d8c816d717 100755 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -192,7 +192,6 @@ HELP: raise-window ARTICLE: "ui-layouts" "Gadget hierarchy and layouts" "A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts." { $subsection "ui-layout-basics" } -{ $subsection "ui-layout-combinators" } "Common layout gadgets:" { $subsection "ui-pack-layout" } { $subsection "ui-track-layout" } @@ -230,12 +229,6 @@ $nl { $subsection pref-dim* } "To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ; -ARTICLE: "ui-layout-combinators" "Creating layouts using combinators" -"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise." -$nl -"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors." -; - ARTICLE: "ui-null-layout" "Manual layouts" "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 22abfc8f21..da9e2f0d43 100755 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs io kernel math models namespaces +USING: arrays assocs io kernel math models namespaces make prettyprint dlists deques sequences threads sequences words debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 0234a959da..5e961e2d67 100755 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,4 +1,4 @@ -USING: unicode.data sequences sequences.next namespaces +USING: unicode.data sequences sequences.next namespaces make unicode.normalize math unicode.categories combinators assocs strings splitting kernel accessors ; IN: unicode.case diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 6f36461d38..53a38faed4 100755 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -1,4 +1,4 @@ -USING: sequences namespaces unicode.data kernel math arrays +USING: sequences namespaces make unicode.data kernel math arrays locals sorting.insertion accessors ; IN: unicode.normalize diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor index 9df14a3928..1ba76fd380 100755 --- a/basis/unicode/syntax/syntax.factor +++ b/basis/unicode/syntax/syntax.factor @@ -1,6 +1,6 @@ -USING: unicode.data kernel math sequences parser lexer bit-arrays -namespaces sequences.private arrays quotations assocs -classes.predicate math.order eval ; +USING: unicode.data kernel math sequences parser lexer +bit-arrays namespaces make sequences.private arrays quotations +assocs classes.predicate math.order eval ; IN: unicode.syntax ! Character classes (categories) diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 299f305371..92a05806b5 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -105,7 +105,7 @@ TUPLE: url protocol username password host port path query anchor ; swap query>> at ; : set-query-param ( url value key -- url ) - '[ , , _ ?set-at ] change-query ; + '[ [ , , ] dip ?set-at ] change-query ; : parse-host ( string -- host port ) ":" split1 [ url-decode ] [ diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 5ec96bbbb0..67a789a1dc 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions assocs kernel kernel.private -slots.private namespaces sequences strings words vectors math -quotations combinators sorting effects graphs vocabs sets ; +slots.private namespaces make sequences strings words vectors +math quotations combinators sorting effects graphs vocabs sets ; IN: classes SYMBOL: class<=-cache diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index e6d6b5a0d4..4ba93acae4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.algebra kernel namespaces words sequences -quotations arrays kernel.private assocs combinators ; +USING: classes classes.algebra kernel namespaces make words +sequences quotations arrays kernel.private assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 531658a5e0..c190ce85e7 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sets namespaces sequences parser +USING: accessors kernel sets namespaces make sequences parser lexer combinators words classes.parser classes.tuple arrays slots math assocs ; IN: classes.tuple.parser diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b5c3658542..f92c9c0fd5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions hashtables kernel kernel.private math -namespaces sequences sequences.private strings vectors words -quotations memory combinators generic classes classes.algebra -classes.builtin classes.private slots.private slots -compiler.units math.private accessors assocs effects ; +namespaces make sequences sequences.private strings vectors +words quotations memory combinators generic classes +classes.algebra classes.builtin classes.private slots.private +slots compiler.units math.private accessors assocs effects ; IN: classes.tuple PREDICATE: tuple-class < class diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index e21348fd19..7a28c1fb99 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs io sequences +USING: kernel namespaces make assocs io sequences sorting continuations math math.parser ; IN: compiler.errors diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index bfa3848186..6dde851963 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences -namespaces math splitting sorting quotations assocs +namespaces make math splitting sorting quotations assocs combinators accessors ; IN: continuations diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 154e1c30ac..afc956fae4 100755 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations kernel namespaces +USING: accessors continuations kernel namespaces make sequences vectors ; IN: destructors diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 8a000b0615..0c082477c7 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser namespaces sequences strings +USING: kernel math math.parser namespaces make sequences strings words assocs combinators accessors arrays ; IN: effects diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c0a21dbaba..026e372912 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors words kernel sequences namespaces assocs +USING: accessors words kernel sequences namespaces make assocs hashtables definitions kernel.private classes classes.private classes.algebra quotations arrays vocabs effects combinators sets ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 834e19d9d9..077795c4b7 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private -math namespaces sequences words quotations layouts combinators +USING: arrays generic hashtables kernel kernel.private math +namespaces make sequences words quotations layouts combinators sequences.private classes classes.builtin classes.algebra definitions math.order ; IN: generic.math diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 02a7af105f..50813f191c 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -1,4 +1,6 @@ -USING: classes.private generic.standard.engines namespaces +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.private generic.standard.engines namespaces make arrays assocs sequences.private quotations kernel.private math slots.private math.private kernel accessors words layouts ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 325f2ebb39..8c61aa4240 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes.tuple.private hashtables assocs sorting accessors combinators sequences slots.private math.parser words -effects namespaces generic generic.standard.engines +effects namespaces make generic generic.standard.engines classes.algebra math math.private kernel.private quotations arrays definitions ; IN: generic.standard.engines.tuple diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 860781e5e2..d22d20a0fc 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel kernel.private slots.private math -namespaces sequences vectors words quotations definitions +namespaces make sequences vectors words quotations definitions hashtables layouts combinators sequences.private generic classes classes.algebra classes.private generic.standard.engines generic.standard.engines.tag generic.standard.engines.predicate diff --git a/core/io/io.factor b/core/io/io.factor index a03aaac6d8..0d5a857490 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables generic kernel math namespaces sequences +USING: hashtables generic kernel math namespaces make sequences continuations destructors assocs ; IN: io diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index de6d8519ca..780d892d2e 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces io io.encodings +USING: kernel kernel.private namespaces make io io.encodings sequences math generic threads.private classes io.backend io.files continuations destructors byte-arrays accessors ; IN: io.streams.c diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index 1d2a24057c..bcc75a842a 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax math math.private prettyprint -namespaces strings ; +namespaces make strings ; IN: math.parser ARTICLE: "number-strings" "Converting between numbers and strings" diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 05e267f035..04d8fb6a41 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private namespaces sequences strings arrays -combinators splitting math assocs ; +USING: kernel math.private namespaces make sequences strings +arrays combinators splitting math assocs ; IN: math.parser : digit> ( ch -- n ) diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 1da3bc45db..f410148566 100755 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -22,13 +22,6 @@ ARTICLE: "namespaces-global" "Global variables" { $subsection get-global } { $subsection set-global } ; -ARTICLE: "namespaces-make" "Constructing sequences" -"There is a lexicon of words for constructing sequences without passing the partial sequence being built on the stack. This reduces stack noise." -{ $subsection make } -{ $subsection , } -{ $subsection % } -{ $subsection # } ; - ARTICLE: "namespaces.private" "Namespace implementation details" "The namestack holds namespaces." { $subsection namestack } @@ -50,8 +43,6 @@ $nl { $subsection "namespaces-change" } { $subsection "namespaces-combinators" } { $subsection "namespaces-global" } -"A useful facility for constructing sequences by holding an accumulator sequence in a variable:" -{ $subsection "namespaces-make" } "Implementation details your code probably does not care about:" { $subsection "namespaces.private" } "An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ; @@ -162,22 +153,6 @@ HELP: >n HELP: ndrop { $description "Pops a namespace from the name stack." } ; -HELP: building -{ $var-description "Temporary mutable growable sequence holding elements accumulated so far by " { $link make } "." } ; - -HELP: make -{ $values { "quot" quotation } { "exemplar" "a sequence" } { "seq" "a new sequence" } } -{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." } -{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; - -HELP: , -{ $values { "elt" object } } -{ $description "Adds an element to the end of the sequence being constructed by " { $link make } "." } ; - -HELP: % -{ $values { "seq" "a sequence" } } -{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; - HELP: init-namespaces { $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } $low-level-note ; diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 3d3d3c554b..20400f4e54 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel vectors sequences hashtables arrays kernel.private math strings assocs ; @@ -6,9 +6,7 @@ IN: namespaces n ( namespace -- ) namestack* push ; : ndrop ( -- ) namestack* pop* ; @@ -25,18 +23,11 @@ PRIVATE> : off ( variable -- ) f swap set ; inline : get-global ( variable -- value ) global at ; : set-global ( value variable -- ) global set-at ; - -: change ( variable quot -- ) - >r dup get r> rot slip set ; inline - +: change ( variable quot -- ) >r dup get r> rot slip set ; inline : +@ ( n variable -- ) [ 0 or + ] change ; - : inc ( variable -- ) 1 swap +@ ; inline - : dec ( variable -- ) -1 swap +@ ; inline - : bind ( ns quot -- ) swap >n call ndrop ; inline - : counter ( variable -- n ) global [ dup inc get ] bind ; : make-assoc ( quot exemplar -- hash ) @@ -47,19 +38,3 @@ PRIVATE> : with-variable ( value key quot -- ) >r associate >n r> call ndrop ; inline - -! Building sequences -SYMBOL: building - -: make ( quot exemplar -- seq ) - [ - [ - 1024 swap new-resizable [ - building set call - ] keep - ] keep like - ] with-scope ; inline - -: , ( elt -- ) building get push ; - -: % ( seq -- ) building get push-all ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 6f831c30c5..d4ae60ca94 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays kernel kernel.private math namespaces -sequences strings words effects generic generic.standard classes -classes.algebra slots.private combinators accessors words -sequences.private assocs alien ; +make sequences strings words effects generic generic.standard +classes classes.algebra slots.private combinators accessors +words sequences.private assocs alien ; IN: slots TUPLE: slot-spec name offset class initial read-only ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 38f5ae0891..aac32784a1 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces strings arrays vectors sequences +USING: kernel math make strings arrays vectors sequences sets math.order accessors ; IN: splitting diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 8d95254539..2695860a59 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs namespaces splitting sequences +USING: kernel assocs namespaces make splitting sequences strings math.parser lexer accessors ; IN: strings.parser diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 4677a7b5d7..44f538d5d9 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces sequences io.files kernel assocs words vocabs -definitions parser continuations io hashtables sorting +USING: namespaces make sequences io.files kernel assocs words +vocabs definitions parser continuations io hashtables sorting source-files arrays combinators strings system math.parser compiler.errors splitting init accessors ; IN: vocabs.loader diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index e110cb38d3..bff720b2a3 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -51,7 +51,7 @@ M: identity monad-of drop identity-monad ; M: identity-monad return drop identity boa ; M: identity-monad fail "Fail" throw ; -M: identity >>= value>> '[ , _ call ] ; +M: identity >>= value>> '[ , swap call ] ; : run-identity ( identity -- value ) value>> ; @@ -73,7 +73,7 @@ M: maybe-monad return drop just ; M: maybe-monad fail 2drop nothing ; M: nothing >>= '[ drop , ] ; -M: just >>= value>> '[ , _ call ] ; +M: just >>= value>> '[ , swap call ] ; : if-maybe ( maybe just-quot nothing-quot -- ) pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline @@ -97,7 +97,7 @@ M: either-monad return drop right ; M: either-monad fail drop left ; M: left >>= '[ drop , ] ; -M: right >>= value>> '[ , _ call ] ; +M: right >>= value>> '[ , swap call ] ; : if-either ( value left-quot right-quot -- ) [ [ value>> ] [ left? ] bi ] 2dip if ; inline @@ -112,7 +112,7 @@ M: array-monad fail 2drop { } ; M: array monad-of drop array-monad ; -M: array >>= '[ , _ map concat ] ; +M: array >>= '[ , swap map concat ] ; ! List SINGLETON: list-monad @@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ; M: list monad-of drop list-monad ; -M: list >>= '[ , _ lazy-map lconcat ] ; +M: list >>= '[ , swap lazy-map lconcat ] ; ! State SINGLETON: state-monad @@ -142,7 +142,7 @@ M: state-monad fail "Fail" throw ; : mcall ( state -- ) quot>> call ; -M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ; +M: state >>= '[ , swap '[ , mcall first2 @ mcall ] state ] ; : get-st ( -- state ) [ dup 2array ] state ; : put-st ( value -- state ) '[ drop , f 2array ] state ; @@ -164,7 +164,7 @@ M: reader monad-of drop reader-monad ; M: reader-monad return drop '[ drop , ] reader ; M: reader-monad fail "Fail" throw ; -M: reader >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ; +M: reader >>= '[ , swap '[ dup , mcall @ mcall ] reader ] ; : run-reader ( reader env -- ) swap mcall ; @@ -185,7 +185,7 @@ M: writer-monad fail "Fail" throw ; : run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ; -M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ; +M: writer >>= '[ [ , run-writer ] dip '[ @ run-writer ] dip append writer ] ; : pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ; : listen ( writer -- writer' ) run-writer [ 2array ] keep writer ; diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 50e2df2e9e..83ed445593 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -23,7 +23,7 @@ DEFER: (del-page) [ names>> ] [ model>> ] [ toggler>> ] tri [ clear-gadget ] keep [ [ length ] keep ] 2dip - '[ , _ _ , add-toggle ] 2each ; + '[ [ , ] 2dip , add-toggle ] 2each ; : refresh-book ( tabbed -- ) model>> [ ] change-model ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 5f679be431..f36e8a11f0 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -93,18 +93,12 @@ M: revision feed-entry-url id>> revision-url ;
select-tuple dup [ revision>> select-tuple ] when ; -: init-relative-link-prefix ( -- ) - URL" $wiki/view/" adjust-url present relative-link-prefix set ; - : ( -- action ) "title" >>rest - [ - validate-title - init-relative-link-prefix - ] >>init + [ validate-title ] >>init [ "title" value dup latest-revision [ @@ -126,7 +120,6 @@ M: revision feed-entry-url id>> revision-url ; validate-integer-id "id" value select-tuple from-object - init-relative-link-prefix ] >>init { wiki "view" } >>template diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index e37f7d4c3f..a35358ae6b 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -74,20 +74,24 @@ SYMBOL: dh-file "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global "slava@factorcode.org" insomniac-recipients set-global - main-responder set-global init-factor-db ; : init-testing ( -- ) "resource:basis/openssl/test/dh1024.pem" dh-file set-global "resource:basis/openssl/test/server.pem" key-file set-global "password" key-password set-global - common-configuration ; + common-configuration + main-responder set-global ; + +: no-www-prefix ( -- responder ) + "http://concatenative.org" ; : init-production ( -- ) - f dh-file set-global - f key-password set-global - "/home/slava/cert/host.pem" key-file set-global - common-configuration ; + common-configuration + + "concatenative.org" add-responder + no-www-prefix "www.concatenative.org" add-responder + main-responder set-global ; : ( -- config ) From 63a1e604aea683cf852c8b589ed6c4cbf8705332 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 20:07:07 -0500 Subject: [PATCH 08/39] make vocabulary --- core/make/make-docs.factor | 30 ++++++++++++++++++++++++++++++ core/make/make.factor | 19 +++++++++++++++++++ 2 files changed, 49 insertions(+) create mode 100644 core/make/make-docs.factor create mode 100644 core/make/make.factor diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor new file mode 100644 index 0000000000..162d1fc8b6 --- /dev/null +++ b/core/make/make-docs.factor @@ -0,0 +1,30 @@ +IN: make +USING: help.markup help.syntax quotations sequences math.parser +kernel ; + +ARTICLE: "namespaces-make" "Constructing sequences" +"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an accumulator sequence in a variable. Storing the accumulator sequence in a variable rather than the stack may allow code to be written with less stack manipulation." +{ $subsection make } +{ $subsection , } +{ $subsection % } +{ $subsection # } +"The accumulator sequence can be accessed directly:" +{ $subsection building } ; + +ABOUT: "namespaces-make" + +HELP: building +{ $var-description "Temporary mutable growable sequence holding elements accumulated so far by " { $link make } "." } ; + +HELP: make +{ $values { "quot" quotation } { "exemplar" sequence } { "seq" "a new sequence" } } +{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." } +{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; + +HELP: , +{ $values { "elt" object } } +{ $description "Adds an element to the end of the sequence being constructed by " { $link make } "." } ; + +HELP: % +{ $values { "seq" sequence } } +{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; diff --git a/core/make/make.factor b/core/make/make.factor new file mode 100644 index 0000000000..f8bdaa1dbb --- /dev/null +++ b/core/make/make.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces ; +IN: make + +SYMBOL: building + +: make ( quot exemplar -- seq ) + [ + [ + 1024 swap new-resizable [ + building set call + ] keep + ] keep like + ] with-scope ; inline + +: , ( elt -- ) building get push ; + +: % ( seq -- ) building get push-all ; From 7ab9af6a9e7914fc7f8c5c0ae6c7cf3526019692 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 20:45:48 -0500 Subject: [PATCH 09/39] make a webapp that shows you your ip --- extra/webapps/ip/ip.factor | 16 ++++++++++++++++ extra/webapps/ip/ip.xml | 7 +++++++ 2 files changed, 23 insertions(+) create mode 100644 extra/webapps/ip/ip.factor create mode 100644 extra/webapps/ip/ip.xml diff --git a/extra/webapps/ip/ip.factor b/extra/webapps/ip/ip.factor new file mode 100644 index 0000000000..7124d4a5c4 --- /dev/null +++ b/extra/webapps/ip/ip.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions http.server.dispatchers +html.forms io.servers.connection namespaces prettyprint ; +IN: webapps.ip + +TUPLE: ip-app < dispatcher ; + +: ( -- action ) + + [ remote-address get host>> "ip" set-value ] >>init + { ip-app "ip" } >>template ; + +: ( -- dispatcher ) + ip-app new-dispatcher + "" add-responder ; diff --git a/extra/webapps/ip/ip.xml b/extra/webapps/ip/ip.xml new file mode 100644 index 0000000000..c8529c27ce --- /dev/null +++ b/extra/webapps/ip/ip.xml @@ -0,0 +1,7 @@ + + + + Your IP address is: + + + From 01a741a30b0f45630bca052e7bdf97d4f61ad061 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 20:47:37 -0500 Subject: [PATCH 10/39] fix help lint --- basis/db/db-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 9395fcce32..f8e3956b3e 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -12,11 +12,11 @@ HELP: new-db { $description "Creates a new database object from a given class." } ; HELP: make-db* -{ $values { "seq" sequence } { "db" object } { "db" object } } +{ $values { "object" object } { "db" object } { "db" object } } { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; HELP: make-db -{ $values { "seq" sequence } { "class" class } { "db" db } } +{ $values { "object" object } { "class" class } { "db" db } } { $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ; HELP: db-open From ffb482675df63269fe86c18cd35a9565288bc7ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 21:11:24 -0500 Subject: [PATCH 11/39] update ogg player for new accessors, delegation. sound is broken --- extra/ogg/authors.txt | 1 + extra/ogg/ogg.factor | 132 +++++++ extra/ogg/player/authors.txt | 1 + extra/ogg/player/player.factor | 631 +++++++++++++++++++++++++++++++++ extra/ogg/player/summary.txt | 1 + extra/ogg/player/tags.txt | 2 + extra/ogg/summary.txt | 1 + extra/ogg/tags.txt | 3 + extra/ogg/theora/authors.txt | 1 + extra/ogg/theora/summary.txt | 1 + extra/ogg/theora/tags.txt | 1 + extra/ogg/theora/theora.factor | 120 +++++++ extra/ogg/vorbis/authors.txt | 1 + extra/ogg/vorbis/summary.txt | 1 + extra/ogg/vorbis/tags.txt | 1 + extra/ogg/vorbis/vorbis.factor | 141 ++++++++ 16 files changed, 1039 insertions(+) create mode 100644 extra/ogg/authors.txt create mode 100644 extra/ogg/ogg.factor create mode 100644 extra/ogg/player/authors.txt create mode 100755 extra/ogg/player/player.factor create mode 100644 extra/ogg/player/summary.txt create mode 100644 extra/ogg/player/tags.txt create mode 100644 extra/ogg/summary.txt create mode 100644 extra/ogg/tags.txt create mode 100644 extra/ogg/theora/authors.txt create mode 100644 extra/ogg/theora/summary.txt create mode 100644 extra/ogg/theora/tags.txt create mode 100644 extra/ogg/theora/theora.factor create mode 100644 extra/ogg/vorbis/authors.txt create mode 100644 extra/ogg/vorbis/summary.txt create mode 100644 extra/ogg/vorbis/tags.txt create mode 100644 extra/ogg/vorbis/vorbis.factor diff --git a/extra/ogg/authors.txt b/extra/ogg/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/ogg/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor new file mode 100644 index 0000000000..37dd30f7fd --- /dev/null +++ b/extra/ogg/ogg.factor @@ -0,0 +1,132 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel system combinators alien alien.syntax ; +IN: ogg + +<< +"ogg" { + { [ os winnt? ] [ "ogg.dll" ] } + { [ os macosx? ] [ "libogg.0.dylib" ] } + { [ os unix? ] [ "libogg.so" ] } +} cond "cdecl" add-library +>> + +LIBRARY: ogg + +C-STRUCT: oggpack_buffer + { "long" "endbyte" } + { "int" "endbit" } + { "uchar*" "buffer" } + { "uchar*" "ptr" } + { "long" "storage" } ; + +C-STRUCT: ogg_page + { "uchar*" "header" } + { "long" "header_len" } + { "uchar*" "body" } + { "long" "body_len" } ; + +C-STRUCT: ogg_stream_state + { "uchar*" "body_data" } + { "long" "body_storage" } + { "long" "body_fill" } + { "long" "body_returned" } + { "int*" "lacing_vals" } + { "longlong*" "granule_vals" } + { "long" "lacing_storage" } + { "long" "lacing_fill" } + { "long" "lacing_packet" } + { "long" "lacing_returned" } + { { "uchar" 282 } "header" } + { "int" "header_fill" } + { "int" "e_o_s" } + { "int" "b_o_s" } + { "long" "serialno" } + { "long" "pageno" } + { "longlong" "packetno" } + { "longlong" "granulepos" } ; + +C-STRUCT: ogg_packet + { "uchar*" "packet" } + { "long" "bytes" } + { "long" "b_o_s" } + { "long" "e_o_s" } + { "longlong" "granulepos" } + { "longlong" "packetno" } ; + +C-STRUCT: ogg_sync_state + { "uchar*" "data" } + { "int" "storage" } + { "int" "fill" } + { "int" "returned" } + { "int" "unsynced" } + { "int" "headerbytes" } + { "int" "bodybytes" } ; + +FUNCTION: void oggpack_writeinit ( oggpack_buffer* b ) ; +FUNCTION: void oggpack_writetrunc ( oggpack_buffer* b, long bits ) ; +FUNCTION: void oggpack_writealign ( oggpack_buffer* b) ; +FUNCTION: void oggpack_writecopy ( oggpack_buffer* b, void* source, long bits ) ; +FUNCTION: void oggpack_reset ( oggpack_buffer* b ) ; +FUNCTION: void oggpack_writeclear ( oggpack_buffer* b ) ; +FUNCTION: void oggpack_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ; +FUNCTION: void oggpack_write ( oggpack_buffer* b, ulong value, int bits ) ; +FUNCTION: long oggpack_look ( oggpack_buffer* b, int bits ) ; +FUNCTION: long oggpack_look1 ( oggpack_buffer* b ) ; +FUNCTION: void oggpack_adv ( oggpack_buffer* b, int bits ) ; +FUNCTION: void oggpack_adv1 ( oggpack_buffer* b ) ; +FUNCTION: long oggpack_read ( oggpack_buffer* b, int bits ) ; +FUNCTION: long oggpack_read1 ( oggpack_buffer* b ) ; +FUNCTION: long oggpack_bytes ( oggpack_buffer* b ) ; +FUNCTION: long oggpack_bits ( oggpack_buffer* b ) ; +FUNCTION: uchar* oggpack_get_buffer ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_writeinit ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_writetrunc ( oggpack_buffer* b, long bits ) ; +FUNCTION: void oggpackB_writealign ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_writecopy ( oggpack_buffer* b, void* source, long bits ) ; +FUNCTION: void oggpackB_reset ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_writeclear ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ; +FUNCTION: void oggpackB_write ( oggpack_buffer* b, ulong value, int bits ) ; +FUNCTION: long oggpackB_look ( oggpack_buffer* b, int bits ) ; +FUNCTION: long oggpackB_look1 ( oggpack_buffer* b ) ; +FUNCTION: void oggpackB_adv ( oggpack_buffer* b, int bits ) ; +FUNCTION: void oggpackB_adv1 ( oggpack_buffer* b ) ; +FUNCTION: long oggpackB_read ( oggpack_buffer* b, int bits ) ; +FUNCTION: long oggpackB_read1 ( oggpack_buffer* b ) ; +FUNCTION: long oggpackB_bytes ( oggpack_buffer* b ) ; +FUNCTION: long oggpackB_bits ( oggpack_buffer* b ) ; +FUNCTION: uchar* oggpackB_get_buffer ( oggpack_buffer* b ) ; +FUNCTION: int ogg_stream_packetin ( ogg_stream_state* os, ogg_packet* op ) ; +FUNCTION: int ogg_stream_pageout ( ogg_stream_state* os, ogg_page* og ) ; +FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ; +FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ; +FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ; +FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ; +FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ; + +FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ; +FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ; +FUNCTION: long ogg_sync_pageseek ( ogg_sync_state* oy, ogg_page* og ) ; +FUNCTION: int ogg_sync_pageout ( ogg_sync_state* oy, ogg_page* og ) ; +FUNCTION: int ogg_stream_pagein ( ogg_stream_state* os, ogg_page* og ) ; +FUNCTION: int ogg_stream_packetout ( ogg_stream_state* os, ogg_packet* op ) ; +FUNCTION: int ogg_stream_packetpeek ( ogg_stream_state* os, ogg_packet* op ) ; +FUNCTION: int ogg_stream_init (ogg_stream_state* os, int serialno ) ; +FUNCTION: int ogg_stream_clear ( ogg_stream_state* os ) ; +FUNCTION: int ogg_stream_reset ( ogg_stream_state* os ) ; +FUNCTION: int ogg_stream_reset_serialno ( ogg_stream_state* os, int serialno ) ; +FUNCTION: int ogg_stream_destroy ( ogg_stream_state* os ) ; +FUNCTION: int ogg_stream_eos ( ogg_stream_state* os ) ; +FUNCTION: void ogg_page_checksum_set ( ogg_page* og ) ; +FUNCTION: int ogg_page_version ( ogg_page* og ) ; +FUNCTION: int ogg_page_continued ( ogg_page* og ) ; +FUNCTION: int ogg_page_bos ( ogg_page* og ) ; +FUNCTION: int ogg_page_eos ( ogg_page* og ) ; +FUNCTION: longlong ogg_page_granulepos ( ogg_page* og ) ; +FUNCTION: int ogg_page_serialno ( ogg_page* og ) ; +FUNCTION: long ogg_page_pageno ( ogg_page* og ) ; +FUNCTION: int ogg_page_packets ( ogg_page* og ) ; +FUNCTION: void ogg_packet_clear ( ogg_packet* op ) ; + diff --git a/extra/ogg/player/authors.txt b/extra/ogg/player/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/ogg/player/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor new file mode 100755 index 0000000000..2204aa441e --- /dev/null +++ b/extra/ogg/player/player.factor @@ -0,0 +1,631 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +! TODO: +! based on number of channels in file. +! - End of decoding is indicated by an exception when reading the stream. +! How to work around this? C player example uses feof but streams don't +! have that in Factor. +! - Work out openal buffer method that plays nicely with streaming over +! slow connections. +! - Have start/stop/seek methods on the player object. +! +USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays + sequences libc shuffle alien.c-types system openal math + namespaces threads shuffle opengl arrays ui.gadgets.worlds + combinators math.parser ui.gadgets ui.render opengl.gl ui + continuations io.files hints combinators.lib sequences.lib + io.encodings.binary debugger math.order accessors ; + +IN: ogg.player + +: audio-buffer-size ( -- number ) 128 1024 * ; inline + +TUPLE: player stream temp-state + op oy og + vo vi vd vb vc vorbis + to ti tc td yuv rgb theora video-ready? video-time video-granulepos + source buffers buffer-indexes start-time + playing? audio-full? audio-index audio-buffer audio-granulepos + gadget ; + +: init-vorbis ( player -- ) + dup oy>> ogg_sync_init drop + dup vi>> vorbis_info_init + vc>> vorbis_comment_init ; + +: init-theora ( player -- ) + dup ti>> theora_info_init + tc>> theora_comment_init ; + +: init-sound ( player -- ) + init-openal check-error + 1 gen-buffers check-error >>buffers + 2 "uint" >>buffer-indexes + 1 gen-sources check-error first >>source drop ; + +: ( stream -- player ) + player new + swap >>stream + 0 >>vorbis + 0 >>theora + 0 >>video-time + 0 >>video-granulepos + f >>video-ready? + f >>audio-full? + 0 >>audio-index + 0 >>start-time + audio-buffer-size "short" >>audio-buffer + 0 >>audio-granulepos + f >>playing? + "ogg_packet" malloc-object >>op + "ogg_sync_state" malloc-object >>oy + "ogg_page" malloc-object >>og + "ogg_stream_state" malloc-object >>vo + "vorbis_info" malloc-object >>vi + "vorbis_dsp_state" malloc-object >>vd + "vorbis_block" malloc-object >>vb + "vorbis_comment" malloc-object >>vc + "ogg_stream_state" malloc-object >>to + "theora_info" malloc-object >>ti + "theora_comment" malloc-object >>tc + "theora_state" malloc-object >>td + "yuv_buffer" >>yuv + "ogg_stream_state" >>temp-state + dup init-sound + dup init-vorbis + dup init-theora ; + +: num-channels ( player -- channels ) + vi>> vorbis_info-channels ; + +: al-channel-format ( player -- format ) + num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ; + +: get-time ( player -- time ) + dup start-time>> zero? [ + millis >>start-time + ] when + start-time>> millis swap - 1000.0 /f ; + +: clamp ( n -- n ) + 255 min 0 max ; inline + +: stride ( line yuv -- uvy yy ) + [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep + yuv_buffer-y_stride >fixnum * >fixnum ; inline + +: each-with4 ( obj obj obj obj seq quot -- ) + 4 each-withn ; inline + +: compute-y ( yuv uvy yy x -- y ) + + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline + +: compute-v ( yuv uvy yy x -- v ) + nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline + +: compute-u ( yuv uvy yy x -- v ) + nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline + +: compute-yuv ( yuv uvy yy x -- y u v ) + [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline + +: compute-blue ( y u v -- b ) + drop 516 * 128 + swap 298 * + -8 shift clamp ; inline + +: compute-green ( y u v -- g ) + >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ; + inline + +: compute-red ( y u v -- g ) + nip 409 * swap 298 * + 128 + -8 shift clamp ; inline + +: compute-rgb ( y u v -- b g r ) + [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ; + inline + +: store-rgb ( index rgb b g r -- index ) + >r + >r pick 0 + >fixnum pick set-uchar-nth + r> pick 1 + >fixnum pick set-uchar-nth + r> pick 2 + >fixnum pick set-uchar-nth + drop ; inline + +: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index ) + compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline + +: yuv>rgb-row ( index rgb yuv y -- index ) + over stride + pick yuv_buffer-y_width >fixnum + [ yuv>rgb-pixel ] each-with4 ; inline + +: yuv>rgb ( rgb yuv -- ) + 0 -rot + dup yuv_buffer-y_height >fixnum + [ yuv>rgb-row ] each-with2 + drop ; + +HINTS: yuv>rgb byte-array byte-array ; + +: process-video ( player -- player ) + dup gadget>> [ + { + [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ] + [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ] + [ gadget>> relayout-1 yield ] + [ ] + } cleave + ] when ; + +: num-audio-buffers-processed ( player -- player n ) + dup source>> AL_BUFFERS_PROCESSED 0 + [ alGetSourcei check-error ] keep *uint ; + +: append-new-audio-buffer ( player -- player ) + dup buffers>> 1 gen-buffers append >>buffers + [ [ buffers>> second ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> second alSourceQueueBuffers check-error ] keep ; + +: fill-processed-audio-buffer ( player n -- player ) + #! n is the number of audio buffers processed + over >r >r dup source>> r> pick buffer-indexes>> + [ alSourceUnqueueBuffers check-error ] keep + *uint dup r> swap >r al-channel-format rot + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + r> swap >r alSourceQueueBuffers check-error r> ; + +: append-audio ( player -- player bool ) + num-audio-buffers-processed { + { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } + { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] } + [ fill-processed-audio-buffer t ] + } cond ; + +: start-audio ( player -- player bool ) + [ [ buffers>> first ] keep al-channel-format ] keep + [ audio-buffer>> dup length ] keep + [ vi>> vorbis_info-rate alBufferData check-error ] keep + [ source>> 1 ] keep + [ buffers>> first alSourceQueueBuffers check-error ] keep + [ source>> alSourcePlay check-error ] keep + t >>playing? t ; + +: process-audio ( player -- player bool ) + dup playing?>> [ append-audio ] [ start-audio ] if ; + +: read-bytes-into ( dest size stream -- len ) + #! Read the given number of bytes from a stream + #! and store them in the destination byte array. + stream-read >byte-array dup length [ memcpy ] keep ; + +: check-not-negative ( int -- ) + 0 < [ "Word result was a negative number." throw ] when ; + +: buffer-size ( -- number ) + 4096 ; inline + +: sync-buffer ( player -- buffer size player ) + [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ; + +: stream-into-buffer ( buffer size player -- len player ) + [ stream>> read-bytes-into ] keep ; + +: confirm-buffer ( len player -- player eof? ) + [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ; + +: buffer-data ( player -- player eof? ) + #! Take some compressed bitstream data and sync it for + #! page extraction. + sync-buffer stream-into-buffer confirm-buffer ; + +: queue-page ( player -- player ) + #! Push a page into the stream for packetization + [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ] + [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ] + [ ] tri ; + +: retrieve-page ( player -- player bool ) + #! Sync the streams and get a page. Return true if a page was + #! successfully retrieved. + dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ; + +: standard-initial-header? ( player -- player bool ) + dup og>> ogg_page_bos zero? not ; + +: ogg-stream-init ( player -- state player ) + #! Init the encode/decode logical stream state + [ temp-state>> ] keep + [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; + +: ogg-stream-pagein ( state player -- state player ) + #! Add the incoming page to the stream state + [ og>> ogg_stream_pagein drop ] 2keep ; + +: ogg-stream-packetout ( state player -- state player ) + [ op>> ogg_stream_packetout drop ] 2keep ; + +: decode-packet ( player -- state player ) + ogg-stream-init ogg-stream-pagein ogg-stream-packetout ; + +: theora-header? ( player -- player bool ) + #! Is the current page a theora header? + dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ; + +: is-theora-packet? ( player -- player bool ) + dup theora>> zero? [ theora-header? ] [ f ] if ; + +: copy-to-theora-state ( state player -- player ) + #! Copy the state to the theora state structure in the player + [ to>> swap dup length memcpy ] keep ; + +: handle-initial-theora-header ( state player -- player ) + copy-to-theora-state 1 >>theora ; + +: vorbis-header? ( player -- player bool ) + #! Is the current page a vorbis header? + dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ; + +: is-vorbis-packet? ( player -- player bool ) + dup vorbis>> zero? [ vorbis-header? ] [ f ] if ; + +: copy-to-vorbis-state ( state player -- player ) + #! Copy the state to the vorbis state structure in the player + [ vo>> swap dup length memcpy ] keep ; + +: handle-initial-vorbis-header ( state player -- player ) + copy-to-vorbis-state 1 >>vorbis ; + +: handle-initial-unknown-header ( state player -- player ) + swap ogg_stream_clear drop ; + +: process-initial-header ( player -- player bool ) + #! Is this a standard initial header? If not, stop parsing + standard-initial-header? [ + decode-packet { + { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] } + { [ is-theora-packet? ] [ handle-initial-theora-header ] } + [ handle-initial-unknown-header ] + } cond t + ] [ + f + ] if ; + +: parse-initial-headers ( player -- player ) + #! Parse Vorbis headers, ignoring any other type stored + #! in the Ogg container. + retrieve-page [ + process-initial-header [ + parse-initial-headers + ] [ + #! Don't leak the page, get it into the appropriate stream + queue-page + ] if + ] [ + buffer-data not [ parse-initial-headers ] when + ] if ; + +: have-required-vorbis-headers? ( player -- player bool ) + #! Return true if we need to decode vorbis due to there being + #! vorbis headers read from the stream but we don't have them all + #! yet. + dup vorbis>> 1 2 between? not ; + +: have-required-theora-headers? ( player -- player bool ) + #! Return true if we need to decode theora due to there being + #! theora headers read from the stream but we don't have them all + #! yet. + dup theora>> 1 2 between? not ; + +: get-remaining-vorbis-header-packet ( player -- player bool ) + dup [ vo>> ] [ op>> ] bi ogg_stream_packetout { + { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] } + { [ dup zero? ] [ drop f ] } + { [ t ] [ drop t ] } + } cond ; + +: get-remaining-theora-header-packet ( player -- player bool ) + dup [ to>> ] [ op>> ] bi ogg_stream_packetout { + { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] } + { [ dup zero? ] [ drop f ] } + { [ t ] [ drop t ] } + } cond ; + +: decode-remaining-vorbis-header-packet ( player -- player ) + dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [ + "Error parsing vorbis stream; corrupt stream?" throw + ] unless ; + +: decode-remaining-theora-header-packet ( player -- player ) + dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [ + "Error parsing theora stream; corrupt stream?" throw + ] unless ; + +: increment-vorbis-header-count ( player -- player ) + [ 1+ ] change-vorbis ; + +: increment-theora-header-count ( player -- player ) + [ 1+ ] change-theora ; + +: parse-remaining-vorbis-headers ( player -- player ) + have-required-vorbis-headers? not [ + get-remaining-vorbis-header-packet [ + decode-remaining-vorbis-header-packet + increment-vorbis-header-count + parse-remaining-vorbis-headers + ] when + ] when ; + +: parse-remaining-theora-headers ( player -- player ) + have-required-theora-headers? not [ + get-remaining-theora-header-packet [ + decode-remaining-theora-header-packet + increment-theora-header-count + parse-remaining-theora-headers + ] when + ] when ; + +: get-more-header-data ( player -- player ) + buffer-data drop ; + +: parse-remaining-headers ( player -- player ) + have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [ + parse-remaining-vorbis-headers + parse-remaining-theora-headers + retrieve-page [ queue-page ] [ get-more-header-data ] if + parse-remaining-headers + ] when ; + +: tear-down-vorbis ( player -- player ) + dup vi>> vorbis_info_clear + dup vc>> vorbis_comment_clear ; + +: tear-down-theora ( player -- player ) + dup ti>> theora_info_clear + dup tc>> theora_comment_clear ; + +: init-vorbis-codec ( player -- player ) + dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop + dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ; + +: init-theora-codec ( player -- player ) + dup [ td>> ] [ ti>> ] bi theora_decode_init drop + dup ti>> theora_info-frame_width over ti>> theora_info-frame_height + 4 * * >>rgb ; + + +: display-vorbis-details ( player -- player ) + [ + "Ogg logical stream " % + dup vo>> ogg_stream_state-serialno # + " is Vorbis " % + dup vi>> vorbis_info-channels # + " channel " % + dup vi>> vorbis_info-rate # + " Hz audio." % + ] "" make print ; + +: display-theora-details ( player -- player ) + [ + "Ogg logical stream " % + dup to>> ogg_stream_state-serialno # + " is Theora " % + dup ti>> theora_info-width # + "x" % + dup ti>> theora_info-height # + " " % + dup ti>> theora_info-fps_numerator + over ti>> theora_info-fps_denominator /f # + " fps video" % + ] "" make print ; + +: initialize-decoder ( player -- player ) + dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if + dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ; + +: sync-pages ( player -- player ) + retrieve-page [ + queue-page sync-pages + ] when ; + +: audio-buffer-not-ready? ( player -- player bool ) + dup vorbis>> zero? not over audio-full?>> not and ; + +: pending-decoded-audio? ( player -- player pcm len bool ) + f 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ; + +: buffer-space-available ( player -- available ) + audio-buffer-size swap audio-index>> - ; + +: samples-to-read ( player available len -- numread ) + >r swap num-channels / r> min ; + +: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline + +: add-to-buffer ( player val -- ) + over audio-index>> pick audio-buffer>> set-short-nth + [ 1+ ] change-audio-index drop ; + +: get-audio-value ( pcm sample channel -- value ) + rot *void* void*-nth float-nth ; + +: process-channels ( player pcm sample channel -- ) + get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ; + +: (process-sample) ( player pcm sample -- ) + pick num-channels [ process-channels ] each-with3 ; + +: process-samples ( player pcm numread -- ) + [ (process-sample) ] each-with2 ; + +: decode-pending-audio ( player pcm result -- player ) +! [ "ret = " % dup # ] "" make write + pick [ buffer-space-available swap ] keep -rot samples-to-read + pick over >r >r process-samples r> r> swap + ! numread player + dup audio-index>> audio-buffer-size = [ + t >>audio-full? + ] when + dup vd>> vorbis_dsp_state-granulepos dup 0 >= [ + ! numtoread player granulepos + #! This is wrong: fix + pick - >>audio-granulepos + ] [ + ! numtoread player granulepos + pick + >>audio-granulepos + ] if + [ vd>> swap vorbis_synthesis_read drop ] keep ; + +: no-pending-audio ( player -- player bool ) + #! No pending audio. Is there a pending packet to decode. + dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [ + dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop + ] when + t + ] [ + #! Need more data. Break out to suck in another page. + f + ] if ; + +: decode-audio ( player -- player ) + audio-buffer-not-ready? [ + #! If there's pending decoded audio, grab it + pending-decoded-audio? [ + decode-pending-audio decode-audio + ] [ + 2drop no-pending-audio [ decode-audio ] when + ] if + ] when ; + +: video-buffer-not-ready? ( player -- player bool ) + dup theora>> zero? not over video-ready?>> not and ; + +: decode-video ( player -- player ) + video-buffer-not-ready? [ + dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [ + dup [ td>> ] [ op>> ] bi theora_decode_packetin drop + dup td>> theora_state-granulepos >>video-granulepos + dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time + >>video-time + t >>video-ready? + decode-video + ] when + ] when ; + +: decode ( player -- player ) + get-more-header-data sync-pages + decode-audio + decode-video + dup audio-full?>> [ + process-audio [ + f >>audio-full? + 0 >>audio-index + ] when + ] when + dup video-ready?>> [ + dup video-time>> over get-time - dup 0.0 < [ + -0.1 > [ process-video ] when + f >>video-ready? + ] [ + drop + ] if + ] when + decode ; + +: free-malloced-objects ( player -- player ) + { + [ op>> free ] + [ oy>> free ] + [ og>> free ] + [ vo>> free ] + [ vi>> free ] + [ vd>> free ] + [ vb>> free ] + [ vc>> free ] + [ to>> free ] + [ ti>> free ] + [ tc>> free ] + [ td>> free ] + [ ] + } cleave ; + + +: unqueue-openal-buffers ( player -- player ) + [ + + num-audio-buffers-processed over source>> rot buffer-indexes>> swapd + alSourceUnqueueBuffers check-error + ] keep ; + +: delete-openal-buffers ( player -- player ) + [ + buffers>> [ + 1 swap alDeleteBuffers check-error + ] each + ] keep ; + +: delete-openal-source ( player -- player ) + [ source>> 1 swap alDeleteSources check-error ] keep ; + +: cleanup ( player -- player ) + free-malloced-objects + unqueue-openal-buffers + delete-openal-buffers + delete-openal-source ; + +: wait-for-sound ( player -- player ) + #! Waits for the openal to finish playing remaining sounds + dup source>> AL_SOURCE_STATE 0 [ alGetSourcei check-error ] keep + *int AL_PLAYING = [ + 100 sleep + wait-for-sound + ] when ; + +TUPLE: theora-gadget < gadget player ; + +: ( player -- gadget ) + theora-gadget new-gadget + swap >>player ; + +M: theora-gadget pref-dim* + player>> + ti>> dup theora_info-width swap theora_info-height 2array ; + +M: theora-gadget draw-gadget* ( gadget -- ) + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + GL_UNPACK_ALIGNMENT 1 glPixelStorei + [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep + player>> rgb>> glDrawPixels ; + +: initialize-gui ( gadget -- ) + "Theora Player" open-window ; + +: play-ogg ( player -- ) + parse-initial-headers + parse-remaining-headers + initialize-decoder + dup gadget>> [ initialize-gui ] when* + [ decode ] try + wait-for-sound + cleanup + drop ; + +: play-vorbis-stream ( stream -- ) + play-ogg ; + +: play-vorbis-file ( filename -- ) + binary play-vorbis-stream ; + +: play-theora-stream ( stream -- ) + + dup >>gadget + play-ogg ; + +: play-theora-file ( filename -- ) + binary play-theora-stream ; diff --git a/extra/ogg/player/summary.txt b/extra/ogg/player/summary.txt new file mode 100644 index 0000000000..d2e32eff61 --- /dev/null +++ b/extra/ogg/player/summary.txt @@ -0,0 +1 @@ +Ogg vorbis and theora media player diff --git a/extra/ogg/player/tags.txt b/extra/ogg/player/tags.txt new file mode 100644 index 0000000000..1adb6f1a28 --- /dev/null +++ b/extra/ogg/player/tags.txt @@ -0,0 +1,2 @@ +audio +video diff --git a/extra/ogg/summary.txt b/extra/ogg/summary.txt new file mode 100644 index 0000000000..3d2b5511c9 --- /dev/null +++ b/extra/ogg/summary.txt @@ -0,0 +1 @@ +Ogg media library binding diff --git a/extra/ogg/tags.txt b/extra/ogg/tags.txt new file mode 100644 index 0000000000..be30e2cdd4 --- /dev/null +++ b/extra/ogg/tags.txt @@ -0,0 +1,3 @@ +bindings +audio +video diff --git a/extra/ogg/theora/authors.txt b/extra/ogg/theora/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/ogg/theora/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/ogg/theora/summary.txt b/extra/ogg/theora/summary.txt new file mode 100644 index 0000000000..aa5ec1fdf7 --- /dev/null +++ b/extra/ogg/theora/summary.txt @@ -0,0 +1 @@ +Ogg Theora video library binding diff --git a/extra/ogg/theora/tags.txt b/extra/ogg/theora/tags.txt new file mode 100644 index 0000000000..2b68b5238a --- /dev/null +++ b/extra/ogg/theora/tags.txt @@ -0,0 +1 @@ +video diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor new file mode 100644 index 0000000000..3d73fb8820 --- /dev/null +++ b/extra/ogg/theora/theora.factor @@ -0,0 +1,120 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel system combinators alien alien.syntax ; +IN: ogg.theora + +<< +"theora" { + { [ os winnt? ] [ "theora.dll" ] } + { [ os macosx? ] [ "libtheora.0.dylib" ] } + { [ os unix? ] [ "libtheora.so" ] } +} cond "cdecl" add-library +>> + +LIBRARY: theora + +C-STRUCT: yuv_buffer + { "int" "y_width" } + { "int" "y_height" } + { "int" "y_stride" } + { "int" "uv_width" } + { "int" "uv_height" } + { "int" "uv_stride" } + { "void*" "y" } + { "void*" "u" } + { "void*" "v" } ; + +: OC_CS_UNSPECIFIED ( -- number ) 0 ; inline +: OC_CS_ITU_REC_470M ( -- number ) 1 ; inline +: OC_CS_ITU_REC_470BG ( -- number ) 2 ; inline +: OC_CS_NSPACES ( -- number ) 3 ; inline + +TYPEDEF: int theora_colorspace + +: OC_PF_420 ( -- number ) 0 ; inline +: OC_PF_RSVD ( -- number ) 1 ; inline +: OC_PF_422 ( -- number ) 2 ; inline +: OC_PF_444 ( -- number ) 3 ; inline + +TYPEDEF: int theora_pixelformat + +C-STRUCT: theora_info + { "uint" "width" } + { "uint" "height" } + { "uint" "frame_width" } + { "uint" "frame_height" } + { "uint" "offset_x" } + { "uint" "offset_y" } + { "uint" "fps_numerator" } + { "uint" "fps_denominator" } + { "uint" "aspect_numerator" } + { "uint" "aspect_denominator" } + { "theora_colorspace" "colorspace" } + { "int" "target_bitrate" } + { "int" "quality" } + { "int" "quick_p" } + { "uchar" "version_major" } + { "uchar" "version_minor" } + { "uchar" "version_subminor" } + { "void*" "codec_setup" } + { "int" "dropframes_p" } + { "int" "keyframe_auto_p" } + { "uint" "keyframe_frequency" } + { "uint" "keyframe_frequency_force" } + { "uint" "keyframe_data_target_bitrate" } + { "int" "keyframe_auto_threshold" } + { "uint" "keyframe_mindistance" } + { "int" "noise_sensitivity" } + { "int" "sharpness" } + { "theora_pixelformat" "pixelformat" } ; + +C-STRUCT: theora_state + { "theora_info*" "i" } + { "longlong" "granulepos" } + { "void*" "internal_encode" } + { "void*" "internal_decode" } ; + +C-STRUCT: theora_comment + { "char**" "user_comments" } + { "int*" "comment_lengths" } + { "int" "comments" } + { "char*" "vendor" } ; + +: OC_FAULT ( -- number ) -1 ; inline +: OC_EINVAL ( -- number ) -10 ; inline +: OC_DISABLED ( -- number ) -11 ; inline +: OC_BADHEADER ( -- number ) -20 ; inline +: OC_NOTFORMAT ( -- number ) -21 ; inline +: OC_VERSION ( -- number ) -22 ; inline +: OC_IMPL ( -- number ) -23 ; inline +: OC_BADPACKET ( -- number ) -24 ; inline +: OC_NEWPACKET ( -- number ) -25 ; inline +: OC_DUPFRAME ( -- number ) 1 ; inline + +FUNCTION: char* theora_version_string ( ) ; +FUNCTION: uint theora_version_number ( ) ; +FUNCTION: int theora_encode_init ( theora_state* th, theora_info* ti ) ; +FUNCTION: int theora_encode_YUVin ( theora_state* t, yuv_buffer* yuv ) ; +FUNCTION: int theora_encode_packetout ( theora_state* t, int last_p, ogg_packet* op ) ; +FUNCTION: int theora_encode_header ( theora_state* t, ogg_packet* op ) ; +FUNCTION: int theora_encode_comment ( theora_comment* tc, ogg_packet* op ) ; +FUNCTION: int theora_encode_tables ( theora_state* t, ogg_packet* op ) ; +FUNCTION: int theora_decode_header ( theora_info* ci, theora_comment* cc, ogg_packet* op ) ; +FUNCTION: int theora_decode_init ( theora_state* th, theora_info* c ) ; +FUNCTION: int theora_decode_packetin ( theora_state* th, ogg_packet* op ) ; +FUNCTION: int theora_decode_YUVout ( theora_state* th, yuv_buffer* yuv ) ; +FUNCTION: int theora_packet_isheader ( ogg_packet* op ) ; +FUNCTION: int theora_packet_iskeyframe ( ogg_packet* op ) ; +FUNCTION: int theora_granule_shift ( theora_info* ti ) ; +FUNCTION: longlong theora_granule_frame ( theora_state* th, longlong granulepos ) ; +FUNCTION: double theora_granule_time ( theora_state* th, longlong granulepos ) ; +FUNCTION: void theora_info_init ( theora_info* c ) ; +FUNCTION: void theora_info_clear ( theora_info* c ) ; +FUNCTION: void theora_clear ( theora_state* t ) ; +FUNCTION: void theora_comment_init ( theora_comment* tc ) ; +FUNCTION: void theora_comment_add ( theora_comment* tc, char* comment ) ; +FUNCTION: void theora_comment_add_tag ( theora_comment* tc, char* tag, char* value ) ; +FUNCTION: char* theora_comment_query ( theora_comment* tc, char* tag, int count ) ; +FUNCTION: int theora_comment_query_count ( theora_comment* tc, char* tag ) ; +FUNCTION: void theora_comment_clear ( theora_comment* tc ) ; diff --git a/extra/ogg/vorbis/authors.txt b/extra/ogg/vorbis/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/ogg/vorbis/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/ogg/vorbis/summary.txt b/extra/ogg/vorbis/summary.txt new file mode 100644 index 0000000000..1a8118ffe2 --- /dev/null +++ b/extra/ogg/vorbis/summary.txt @@ -0,0 +1 @@ +Ogg Vorbis audio library binding diff --git a/extra/ogg/vorbis/tags.txt b/extra/ogg/vorbis/tags.txt new file mode 100644 index 0000000000..d5cc28426a --- /dev/null +++ b/extra/ogg/vorbis/tags.txt @@ -0,0 +1 @@ +audio diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor new file mode 100644 index 0000000000..5712272ebc --- /dev/null +++ b/extra/ogg/vorbis/vorbis.factor @@ -0,0 +1,141 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel system combinators alien alien.syntax ogg ; +IN: ogg.vorbis + +<< +"vorbis" { + { [ os winnt? ] [ "vorbis.dll" ] } + { [ os macosx? ] [ "libvorbis.0.dylib" ] } + { [ os unix? ] [ "libvorbis.so" ] } +} cond "cdecl" add-library +>> + +LIBRARY: vorbis + +C-STRUCT: vorbis_info + { "int" "version" } + { "int" "channels" } + { "long" "rate" } + { "long" "bitrate_upper" } + { "long" "bitrate_nominal" } + { "long" "bitrate_lower" } + { "long" "bitrate_window" } + { "void*" "codec_setup"} + ; + +C-STRUCT: vorbis_dsp_state + { "int" "analysisp" } + { "vorbis_info*" "vi" } + { "float**" "pcm" } + { "float**" "pcmret" } + { "int" "pcm_storage" } + { "int" "pcm_current" } + { "int" "pcm_returned" } + { "int" "preextrapolate" } + { "int" "eofflag" } + { "long" "lW" } + { "long" "W" } + { "long" "nW" } + { "long" "centerW" } + { "longlong" "granulepos" } + { "longlong" "sequence" } + { "longlong" "glue_bits" } + { "longlong" "time_bits" } + { "longlong" "floor_bits" } + { "longlong" "res_bits" } + { "void*" "backend_state" } + ; + +C-STRUCT: alloc_chain + { "void*" "ptr" } + { "void*" "next" } + ; + +C-STRUCT: vorbis_block + { "float**" "pcm" } + { "oggpack_buffer" "opb" } + { "long" "lW" } + { "long" "W" } + { "long" "nW" } + { "int" "pcmend" } + { "int" "mode" } + { "int" "eofflag" } + { "longlong" "granulepos" } + { "longlong" "sequence" } + { "vorbis_dsp_state*" "vd" } + { "void*" "localstore" } + { "long" "localtop" } + { "long" "localalloc" } + { "long" "totaluse" } + { "alloc_chain*" "reap" } + { "long" "glue_bits" } + { "long" "time_bits" } + { "long" "floor_bits" } + { "long" "res_bits" } + { "void*" "internal" } + ; + +C-STRUCT: vorbis_comment + { "char**" "usercomments" } + { "int*" "comment_lengths" } + { "int" "comments" } + { "char*" "vendor" } + ; + +FUNCTION: void vorbis_info_init ( vorbis_info* vi ) ; +FUNCTION: void vorbis_info_clear ( vorbis_info* vi ) ; +FUNCTION: int vorbis_info_blocksize ( vorbis_info* vi, int zo ) ; +FUNCTION: void vorbis_comment_init ( vorbis_comment* vc ) ; +FUNCTION: void vorbis_comment_add ( vorbis_comment* vc, char* comment ) ; +FUNCTION: void vorbis_comment_add_tag ( vorbis_comment* vc, char* tag, char* contents ) ; +FUNCTION: char* vorbis_comment_query ( vorbis_comment* vc, char* tag, int count ) ; +FUNCTION: int vorbis_comment_query_count ( vorbis_comment* vc, char* tag ) ; +FUNCTION: void vorbis_comment_clear ( vorbis_comment* vc ) ; +FUNCTION: int vorbis_block_init ( vorbis_dsp_state* v, vorbis_block* vb ) ; +FUNCTION: int vorbis_block_clear ( vorbis_block* vb ) ; +FUNCTION: void vorbis_dsp_clear ( vorbis_dsp_state* v ) ; +FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepos ) ; +FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; +FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ; +FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v, + vorbis_comment* vc, + ogg_packet* op, + ogg_packet* op_comm, + ogg_packet* op_code ) ; +FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ; +FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ; +FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ; +FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ; +FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ; +FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd, + ogg_packet* op ) ; +FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc, + ogg_packet* op ) ; +FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; +FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ; +FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ; +FUNCTION: int vorbis_synthesis_trackonly ( vorbis_block* vb, ogg_packet* op ) ; +FUNCTION: int vorbis_synthesis_blockin ( vorbis_dsp_state* v, vorbis_block* vb ) ; +FUNCTION: int vorbis_synthesis_pcmout ( vorbis_dsp_state* v, float*** pcm ) ; +FUNCTION: int vorbis_synthesis_lapout ( vorbis_dsp_state* v, float*** pcm ) ; +FUNCTION: int vorbis_synthesis_read ( vorbis_dsp_state* v, int samples ) ; +FUNCTION: long vorbis_packet_blocksize ( vorbis_info* vi, ogg_packet* op ) ; +FUNCTION: int vorbis_synthesis_halfrate ( vorbis_info* v, int flag ) ; +FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis_info* v ) ; + +: OV_FALSE ( -- number ) -1 ; inline +: OV_EOF ( -- number ) -2 ; inline +: OV_HOLE ( -- number ) -3 ; inline +: OV_EREAD ( -- number ) -128 ; inline +: OV_EFAULT ( -- number ) -129 ; inline +: OV_EIMPL ( -- number ) -130 ; inline +: OV_EINVAL ( -- number ) -131 ; inline +: OV_ENOTVORBIS ( -- number ) -132 ; inline +: OV_EBADHEADER ( -- number ) -133 ; inline +: OV_EVERSION ( -- number ) -134 ; inline +: OV_ENOTAUDIO ( -- number ) -135 ; inline +: OV_EBADPACKET ( -- number ) -136 ; inline +: OV_EBADLINK ( -- number ) -137 ; inline +: OV_ENOSEEK ( -- number ) -138 ; inline From 716fb2966471b100ee16e20d033f4e8287ad5776 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 21:11:59 -0500 Subject: [PATCH 12/39] remove old ogg. could have used git mv i guess. oops --- unmaintained/ogg/authors.txt | 1 - unmaintained/ogg/ogg.factor | 132 ------ unmaintained/ogg/player/authors.txt | 1 - unmaintained/ogg/player/player.factor | 624 -------------------------- unmaintained/ogg/player/summary.txt | 1 - unmaintained/ogg/player/tags.txt | 2 - unmaintained/ogg/summary.txt | 1 - unmaintained/ogg/tags.txt | 3 - unmaintained/ogg/theora/authors.txt | 1 - unmaintained/ogg/theora/summary.txt | 1 - unmaintained/ogg/theora/tags.txt | 1 - unmaintained/ogg/theora/theora.factor | 120 ----- unmaintained/ogg/vorbis/authors.txt | 1 - unmaintained/ogg/vorbis/summary.txt | 1 - unmaintained/ogg/vorbis/tags.txt | 1 - unmaintained/ogg/vorbis/vorbis.factor | 141 ------ 16 files changed, 1032 deletions(-) delete mode 100644 unmaintained/ogg/authors.txt delete mode 100644 unmaintained/ogg/ogg.factor delete mode 100644 unmaintained/ogg/player/authors.txt delete mode 100755 unmaintained/ogg/player/player.factor delete mode 100644 unmaintained/ogg/player/summary.txt delete mode 100644 unmaintained/ogg/player/tags.txt delete mode 100644 unmaintained/ogg/summary.txt delete mode 100644 unmaintained/ogg/tags.txt delete mode 100644 unmaintained/ogg/theora/authors.txt delete mode 100644 unmaintained/ogg/theora/summary.txt delete mode 100644 unmaintained/ogg/theora/tags.txt delete mode 100644 unmaintained/ogg/theora/theora.factor delete mode 100644 unmaintained/ogg/vorbis/authors.txt delete mode 100644 unmaintained/ogg/vorbis/summary.txt delete mode 100644 unmaintained/ogg/vorbis/tags.txt delete mode 100644 unmaintained/ogg/vorbis/vorbis.factor diff --git a/unmaintained/ogg/authors.txt b/unmaintained/ogg/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/ogg/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/ogg/ogg.factor b/unmaintained/ogg/ogg.factor deleted file mode 100644 index 37dd30f7fd..0000000000 --- a/unmaintained/ogg/ogg.factor +++ /dev/null @@ -1,132 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel system combinators alien alien.syntax ; -IN: ogg - -<< -"ogg" { - { [ os winnt? ] [ "ogg.dll" ] } - { [ os macosx? ] [ "libogg.0.dylib" ] } - { [ os unix? ] [ "libogg.so" ] } -} cond "cdecl" add-library ->> - -LIBRARY: ogg - -C-STRUCT: oggpack_buffer - { "long" "endbyte" } - { "int" "endbit" } - { "uchar*" "buffer" } - { "uchar*" "ptr" } - { "long" "storage" } ; - -C-STRUCT: ogg_page - { "uchar*" "header" } - { "long" "header_len" } - { "uchar*" "body" } - { "long" "body_len" } ; - -C-STRUCT: ogg_stream_state - { "uchar*" "body_data" } - { "long" "body_storage" } - { "long" "body_fill" } - { "long" "body_returned" } - { "int*" "lacing_vals" } - { "longlong*" "granule_vals" } - { "long" "lacing_storage" } - { "long" "lacing_fill" } - { "long" "lacing_packet" } - { "long" "lacing_returned" } - { { "uchar" 282 } "header" } - { "int" "header_fill" } - { "int" "e_o_s" } - { "int" "b_o_s" } - { "long" "serialno" } - { "long" "pageno" } - { "longlong" "packetno" } - { "longlong" "granulepos" } ; - -C-STRUCT: ogg_packet - { "uchar*" "packet" } - { "long" "bytes" } - { "long" "b_o_s" } - { "long" "e_o_s" } - { "longlong" "granulepos" } - { "longlong" "packetno" } ; - -C-STRUCT: ogg_sync_state - { "uchar*" "data" } - { "int" "storage" } - { "int" "fill" } - { "int" "returned" } - { "int" "unsynced" } - { "int" "headerbytes" } - { "int" "bodybytes" } ; - -FUNCTION: void oggpack_writeinit ( oggpack_buffer* b ) ; -FUNCTION: void oggpack_writetrunc ( oggpack_buffer* b, long bits ) ; -FUNCTION: void oggpack_writealign ( oggpack_buffer* b) ; -FUNCTION: void oggpack_writecopy ( oggpack_buffer* b, void* source, long bits ) ; -FUNCTION: void oggpack_reset ( oggpack_buffer* b ) ; -FUNCTION: void oggpack_writeclear ( oggpack_buffer* b ) ; -FUNCTION: void oggpack_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ; -FUNCTION: void oggpack_write ( oggpack_buffer* b, ulong value, int bits ) ; -FUNCTION: long oggpack_look ( oggpack_buffer* b, int bits ) ; -FUNCTION: long oggpack_look1 ( oggpack_buffer* b ) ; -FUNCTION: void oggpack_adv ( oggpack_buffer* b, int bits ) ; -FUNCTION: void oggpack_adv1 ( oggpack_buffer* b ) ; -FUNCTION: long oggpack_read ( oggpack_buffer* b, int bits ) ; -FUNCTION: long oggpack_read1 ( oggpack_buffer* b ) ; -FUNCTION: long oggpack_bytes ( oggpack_buffer* b ) ; -FUNCTION: long oggpack_bits ( oggpack_buffer* b ) ; -FUNCTION: uchar* oggpack_get_buffer ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_writeinit ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_writetrunc ( oggpack_buffer* b, long bits ) ; -FUNCTION: void oggpackB_writealign ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_writecopy ( oggpack_buffer* b, void* source, long bits ) ; -FUNCTION: void oggpackB_reset ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_writeclear ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ; -FUNCTION: void oggpackB_write ( oggpack_buffer* b, ulong value, int bits ) ; -FUNCTION: long oggpackB_look ( oggpack_buffer* b, int bits ) ; -FUNCTION: long oggpackB_look1 ( oggpack_buffer* b ) ; -FUNCTION: void oggpackB_adv ( oggpack_buffer* b, int bits ) ; -FUNCTION: void oggpackB_adv1 ( oggpack_buffer* b ) ; -FUNCTION: long oggpackB_read ( oggpack_buffer* b, int bits ) ; -FUNCTION: long oggpackB_read1 ( oggpack_buffer* b ) ; -FUNCTION: long oggpackB_bytes ( oggpack_buffer* b ) ; -FUNCTION: long oggpackB_bits ( oggpack_buffer* b ) ; -FUNCTION: uchar* oggpackB_get_buffer ( oggpack_buffer* b ) ; -FUNCTION: int ogg_stream_packetin ( ogg_stream_state* os, ogg_packet* op ) ; -FUNCTION: int ogg_stream_pageout ( ogg_stream_state* os, ogg_page* og ) ; -FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ; -FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ; -FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ; -FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ; -FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ; - -FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ; -FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ; -FUNCTION: long ogg_sync_pageseek ( ogg_sync_state* oy, ogg_page* og ) ; -FUNCTION: int ogg_sync_pageout ( ogg_sync_state* oy, ogg_page* og ) ; -FUNCTION: int ogg_stream_pagein ( ogg_stream_state* os, ogg_page* og ) ; -FUNCTION: int ogg_stream_packetout ( ogg_stream_state* os, ogg_packet* op ) ; -FUNCTION: int ogg_stream_packetpeek ( ogg_stream_state* os, ogg_packet* op ) ; -FUNCTION: int ogg_stream_init (ogg_stream_state* os, int serialno ) ; -FUNCTION: int ogg_stream_clear ( ogg_stream_state* os ) ; -FUNCTION: int ogg_stream_reset ( ogg_stream_state* os ) ; -FUNCTION: int ogg_stream_reset_serialno ( ogg_stream_state* os, int serialno ) ; -FUNCTION: int ogg_stream_destroy ( ogg_stream_state* os ) ; -FUNCTION: int ogg_stream_eos ( ogg_stream_state* os ) ; -FUNCTION: void ogg_page_checksum_set ( ogg_page* og ) ; -FUNCTION: int ogg_page_version ( ogg_page* og ) ; -FUNCTION: int ogg_page_continued ( ogg_page* og ) ; -FUNCTION: int ogg_page_bos ( ogg_page* og ) ; -FUNCTION: int ogg_page_eos ( ogg_page* og ) ; -FUNCTION: longlong ogg_page_granulepos ( ogg_page* og ) ; -FUNCTION: int ogg_page_serialno ( ogg_page* og ) ; -FUNCTION: long ogg_page_pageno ( ogg_page* og ) ; -FUNCTION: int ogg_page_packets ( ogg_page* og ) ; -FUNCTION: void ogg_packet_clear ( ogg_packet* op ) ; - diff --git a/unmaintained/ogg/player/authors.txt b/unmaintained/ogg/player/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/ogg/player/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/ogg/player/player.factor b/unmaintained/ogg/player/player.factor deleted file mode 100755 index 251206f1d1..0000000000 --- a/unmaintained/ogg/player/player.factor +++ /dev/null @@ -1,624 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! TODO: -! based on number of channels in file. -! - End of decoding is indicated by an exception when reading the stream. -! How to work around this? C player example uses feof but streams don't -! have that in Factor. -! - Work out openal buffer method that plays nicely with streaming over -! slow connections. -! - Have start/stop/seek methods on the player object. -! -USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays - sequences libc shuffle alien.c-types system openal math - namespaces threads shuffle opengl arrays ui.gadgets.worlds - combinators math.parser ui.gadgets ui.render opengl.gl ui - continuations io.files hints combinators.lib sequences.lib - io.encodings.binary debugger math.order ; - -IN: ogg.player - -: audio-buffer-size ( -- number ) 128 1024 * ; inline - -TUPLE: player stream temp-state - op oy og - vo vi vd vb vc vorbis - to ti tc td yuv rgb theora video-ready? video-time video-granulepos - source buffers buffer-indexes start-time - playing? audio-full? audio-index audio-buffer audio-granulepos - gadget ; - -: init-vorbis ( player -- ) - dup player-oy ogg_sync_init drop - dup player-vi vorbis_info_init - player-vc vorbis_comment_init ; - -: init-theora ( player -- ) - dup player-ti theora_info_init - player-tc theora_comment_init ; - -: init-sound ( player -- ) - init-openal check-error - 1 gen-buffers check-error over set-player-buffers - 2 "uint" over set-player-buffer-indexes - 1 gen-sources check-error first swap set-player-source ; - -: ( stream -- player ) - { set-player-stream } player construct - 0 over set-player-vorbis - 0 over set-player-theora - 0 over set-player-video-time - 0 over set-player-video-granulepos - f over set-player-video-ready? - f over set-player-audio-full? - 0 over set-player-audio-index - 0 over set-player-start-time - audio-buffer-size "short" over set-player-audio-buffer - 0 over set-player-audio-granulepos - f over set-player-playing? - "ogg_packet" malloc-object over set-player-op - "ogg_sync_state" malloc-object over set-player-oy - "ogg_page" malloc-object over set-player-og - "ogg_stream_state" malloc-object over set-player-vo - "vorbis_info" malloc-object over set-player-vi - "vorbis_dsp_state" malloc-object over set-player-vd - "vorbis_block" malloc-object over set-player-vb - "vorbis_comment" malloc-object over set-player-vc - "ogg_stream_state" malloc-object over set-player-to - "theora_info" malloc-object over set-player-ti - "theora_comment" malloc-object over set-player-tc - "theora_state" malloc-object over set-player-td - "yuv_buffer" over set-player-yuv - "ogg_stream_state" over set-player-temp-state - dup init-sound - dup init-vorbis - dup init-theora ; - -: num-channels ( player -- channels ) - player-vi vorbis_info-channels ; - -: al-channel-format ( player -- format ) - num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ; - -: get-time ( player -- time ) - dup player-start-time zero? [ - millis over set-player-start-time - ] when - player-start-time millis swap - 1000.0 /f ; - -: clamp ( n -- n ) - 255 min 0 max ; inline - -: stride ( line yuv -- uvy yy ) - [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep - yuv_buffer-y_stride >fixnum * >fixnum ; inline - -: each-with4 ( obj obj obj obj seq quot -- ) - 4 each-withn ; inline - -: compute-y ( yuv uvy yy x -- y ) - + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline - -: compute-v ( yuv uvy yy x -- v ) - nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline - -: compute-u ( yuv uvy yy x -- v ) - nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline - -: compute-yuv ( yuv uvy yy x -- y u v ) - [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline - -: compute-blue ( y u v -- b ) - drop 516 * 128 + swap 298 * + -8 shift clamp ; inline - -: compute-green ( y u v -- g ) - >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ; - inline - -: compute-red ( y u v -- g ) - nip 409 * swap 298 * + 128 + -8 shift clamp ; inline - -: compute-rgb ( y u v -- b g r ) - [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ; - inline - -: store-rgb ( index rgb b g r -- index ) - >r - >r pick 0 + >fixnum pick set-uchar-nth - r> pick 1 + >fixnum pick set-uchar-nth - r> pick 2 + >fixnum pick set-uchar-nth - drop ; inline - -: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index ) - compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline - -: yuv>rgb-row ( index rgb yuv y -- index ) - over stride - pick yuv_buffer-y_width >fixnum - [ yuv>rgb-pixel ] each-with4 ; inline - -: yuv>rgb ( rgb yuv -- ) - 0 -rot - dup yuv_buffer-y_height >fixnum - [ yuv>rgb-row ] each-with2 - drop ; - -HINTS: yuv>rgb byte-array byte-array ; - -: process-video ( player -- player ) - dup player-gadget [ - dup { player-td player-yuv } get-slots theora_decode_YUVout drop - dup player-rgb over player-yuv yuv>rgb - dup player-gadget relayout-1 yield - ] when ; - -: num-audio-buffers-processed ( player -- player n ) - dup player-source AL_BUFFERS_PROCESSED 0 - [ alGetSourcei check-error ] keep *uint ; - -: append-new-audio-buffer ( player -- player ) - dup player-buffers 1 gen-buffers append over set-player-buffers - [ [ player-buffers second ] keep al-channel-format ] keep - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers second alSourceQueueBuffers check-error ] keep ; - -: fill-processed-audio-buffer ( player n -- player ) - #! n is the number of audio buffers processed - over >r >r dup player-source r> pick player-buffer-indexes - [ alSourceUnqueueBuffers check-error ] keep - *uint dup r> swap >r al-channel-format rot - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - r> swap >r alSourceQueueBuffers check-error r> ; - -: append-audio ( player -- player bool ) - num-audio-buffers-processed { - { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } - { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] } - [ fill-processed-audio-buffer t ] - } cond ; - -: start-audio ( player -- player bool ) - [ [ player-buffers first ] keep al-channel-format ] keep - [ player-audio-buffer dup length ] keep - [ player-vi vorbis_info-rate alBufferData check-error ] keep - [ player-source 1 ] keep - [ player-buffers first alSourceQueueBuffers check-error ] keep - [ player-source alSourcePlay check-error ] keep - t over set-player-playing? t ; - -: process-audio ( player -- player bool ) - dup player-playing? [ append-audio ] [ start-audio ] if ; - -: read-bytes-into ( dest size stream -- len ) - #! Read the given number of bytes from a stream - #! and store them in the destination byte array. - stream-read >byte-array dup length [ memcpy ] keep ; - -: check-not-negative ( int -- ) - 0 < [ "Word result was a negative number." throw ] when ; - -: buffer-size ( -- number ) - 4096 ; inline - -: sync-buffer ( player -- buffer size player ) - [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ; - -: stream-into-buffer ( buffer size player -- len player ) - [ player-stream read-bytes-into ] keep ; - -: confirm-buffer ( len player -- player eof? ) - [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ; - -: buffer-data ( player -- player eof? ) - #! Take some compressed bitstream data and sync it for - #! page extraction. - sync-buffer stream-into-buffer confirm-buffer ; - -: queue-page ( player -- player ) - #! Push a page into the stream for packetization - [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep - [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ; - -: retrieve-page ( player -- player bool ) - #! Sync the streams and get a page. Return true if a page was - #! successfully retrieved. - dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ; - -: standard-initial-header? ( player -- player bool ) - dup player-og ogg_page_bos zero? not ; - -: ogg-stream-init ( player -- state player ) - #! Init the encode/decode logical stream state - [ player-temp-state ] keep - [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; - -: ogg-stream-pagein ( state player -- state player ) - #! Add the incoming page to the stream state - [ player-og ogg_stream_pagein drop ] 2keep ; - -: ogg-stream-packetout ( state player -- state player ) - [ player-op ogg_stream_packetout drop ] 2keep ; - -: decode-packet ( player -- state player ) - ogg-stream-init ogg-stream-pagein ogg-stream-packetout ; - -: theora-header? ( player -- player bool ) - #! Is the current page a theora header? - dup { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ; - -: is-theora-packet? ( player -- player bool ) - dup player-theora zero? [ theora-header? ] [ f ] if ; - -: copy-to-theora-state ( state player -- player ) - #! Copy the state to the theora state structure in the player - [ player-to swap dup length memcpy ] keep ; - -: handle-initial-theora-header ( state player -- player ) - copy-to-theora-state 1 over set-player-theora ; - -: vorbis-header? ( player -- player bool ) - #! Is the current page a vorbis header? - dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ; - -: is-vorbis-packet? ( player -- player bool ) - dup player-vorbis zero? [ vorbis-header? ] [ f ] if ; - -: copy-to-vorbis-state ( state player -- player ) - #! Copy the state to the vorbis state structure in the player - [ player-vo swap dup length memcpy ] keep ; - -: handle-initial-vorbis-header ( state player -- player ) - copy-to-vorbis-state 1 over set-player-vorbis ; - -: handle-initial-unknown-header ( state player -- player ) - swap ogg_stream_clear drop ; - -: process-initial-header ( player -- player bool ) - #! Is this a standard initial header? If not, stop parsing - standard-initial-header? [ - decode-packet { - { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] } - { [ is-theora-packet? ] [ handle-initial-theora-header ] } - [ handle-initial-unknown-header ] - } cond t - ] [ - f - ] if ; - -: parse-initial-headers ( player -- player ) - #! Parse Vorbis headers, ignoring any other type stored - #! in the Ogg container. - retrieve-page [ - process-initial-header [ - parse-initial-headers - ] [ - #! Don't leak the page, get it into the appropriate stream - queue-page - ] if - ] [ - buffer-data not [ parse-initial-headers ] when - ] if ; - -: have-required-vorbis-headers? ( player -- player bool ) - #! Return true if we need to decode vorbis due to there being - #! vorbis headers read from the stream but we don't have them all - #! yet. - dup player-vorbis 1 2 between? not ; - -: have-required-theora-headers? ( player -- player bool ) - #! Return true if we need to decode theora due to there being - #! theora headers read from the stream but we don't have them all - #! yet. - dup player-theora 1 2 between? not ; - -: get-remaining-vorbis-header-packet ( player -- player bool ) - dup { player-vo player-op } get-slots ogg_stream_packetout { - { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] } - { [ dup zero? ] [ drop f ] } - { [ t ] [ drop t ] } - } cond ; - -: get-remaining-theora-header-packet ( player -- player bool ) - dup { player-to player-op } get-slots ogg_stream_packetout { - { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] } - { [ dup zero? ] [ drop f ] } - { [ t ] [ drop t ] } - } cond ; - -: decode-remaining-vorbis-header-packet ( player -- player ) - dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [ - "Error parsing vorbis stream; corrupt stream?" throw - ] unless ; - -: decode-remaining-theora-header-packet ( player -- player ) - dup { player-ti player-tc player-op } get-slots theora_decode_header zero? [ - "Error parsing theora stream; corrupt stream?" throw - ] unless ; - -: increment-vorbis-header-count ( player -- player ) - dup player-vorbis 1+ over set-player-vorbis ; - -: increment-theora-header-count ( player -- player ) - dup player-theora 1+ over set-player-theora ; - -: parse-remaining-vorbis-headers ( player -- player ) - have-required-vorbis-headers? not [ - get-remaining-vorbis-header-packet [ - decode-remaining-vorbis-header-packet - increment-vorbis-header-count - parse-remaining-vorbis-headers - ] when - ] when ; - -: parse-remaining-theora-headers ( player -- player ) - have-required-theora-headers? not [ - get-remaining-theora-header-packet [ - decode-remaining-theora-header-packet - increment-theora-header-count - parse-remaining-theora-headers - ] when - ] when ; - -: get-more-header-data ( player -- player ) - buffer-data drop ; - -: parse-remaining-headers ( player -- player ) - have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [ - parse-remaining-vorbis-headers - parse-remaining-theora-headers - retrieve-page [ queue-page ] [ get-more-header-data ] if - parse-remaining-headers - ] when ; - -: tear-down-vorbis ( player -- player ) - dup player-vi vorbis_info_clear - dup player-vc vorbis_comment_clear ; - -: tear-down-theora ( player -- player ) - dup player-ti theora_info_clear - dup player-tc theora_comment_clear ; - -: init-vorbis-codec ( player -- player ) - dup { player-vd player-vi } get-slots vorbis_synthesis_init drop - dup { player-vd player-vb } get-slots vorbis_block_init drop ; - -: init-theora-codec ( player -- player ) - dup { player-td player-ti } get-slots theora_decode_init drop - dup player-ti theora_info-frame_width over player-ti theora_info-frame_height - 4 * * over set-player-rgb ; - - -: display-vorbis-details ( player -- player ) - [ - "Ogg logical stream " % - dup player-vo ogg_stream_state-serialno # - " is Vorbis " % - dup player-vi vorbis_info-channels # - " channel " % - dup player-vi vorbis_info-rate # - " Hz audio." % - ] "" make print ; - -: display-theora-details ( player -- player ) - [ - "Ogg logical stream " % - dup player-to ogg_stream_state-serialno # - " is Theora " % - dup player-ti theora_info-width # - "x" % - dup player-ti theora_info-height # - " " % - dup player-ti theora_info-fps_numerator - over player-ti theora_info-fps_denominator /f # - " fps video" % - ] "" make print ; - -: initialize-decoder ( player -- player ) - dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if - dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ; - -: sync-pages ( player -- player ) - retrieve-page [ - queue-page sync-pages - ] when ; - -: audio-buffer-not-ready? ( player -- player bool ) - dup player-vorbis zero? not over player-audio-full? not and ; - -: pending-decoded-audio? ( player -- player pcm len bool ) - f 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ; - -: buffer-space-available ( player -- available ) - audio-buffer-size swap player-audio-index - ; - -: samples-to-read ( player available len -- numread ) - >r swap num-channels / r> min ; - -: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline - -: add-to-buffer ( player val -- ) - over player-audio-index pick player-audio-buffer set-short-nth - dup player-audio-index 1+ swap set-player-audio-index ; - -: get-audio-value ( pcm sample channel -- value ) - rot *void* void*-nth float-nth ; - -: process-channels ( player pcm sample channel -- ) - get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ; - -: (process-sample) ( player pcm sample -- ) - pick num-channels [ process-channels ] each-with3 ; - -: process-samples ( player pcm numread -- ) - [ (process-sample) ] each-with2 ; - -: decode-pending-audio ( player pcm result -- player ) -! [ "ret = " % dup # ] "" make write - pick [ buffer-space-available swap ] keep -rot samples-to-read - pick over >r >r process-samples r> r> swap - ! numread player - dup player-audio-index audio-buffer-size = [ - t over set-player-audio-full? - ] when - dup player-vd vorbis_dsp_state-granulepos dup 0 >= [ - ! numtoread player granulepos - #! This is wrong: fix - pick - over set-player-audio-granulepos - ] [ - ! numtoread player granulepos - pick + over set-player-audio-granulepos - ] if - [ player-vd swap vorbis_synthesis_read drop ] keep ; - -: no-pending-audio ( player -- player bool ) - #! No pending audio. Is there a pending packet to decode. - dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [ - dup { player-vb player-op } get-slots vorbis_synthesis 0 = [ - dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop - ] when - t - ] [ - #! Need more data. Break out to suck in another page. - f - ] if ; - -: decode-audio ( player -- player ) - audio-buffer-not-ready? [ - #! If there's pending decoded audio, grab it - pending-decoded-audio? [ - decode-pending-audio decode-audio - ] [ - 2drop no-pending-audio [ decode-audio ] when - ] if - ] when ; - -: video-buffer-not-ready? ( player -- player bool ) - dup player-theora zero? not over player-video-ready? not and ; - -: decode-video ( player -- player ) - video-buffer-not-ready? [ - dup { player-to player-op } get-slots ogg_stream_packetout 0 > [ - dup { player-td player-op } get-slots theora_decode_packetin drop - dup player-td theora_state-granulepos over set-player-video-granulepos - dup { player-td player-video-granulepos } get-slots theora_granule_time - over set-player-video-time - t over set-player-video-ready? - decode-video - ] when - ] when ; - -: decode ( player -- player ) - get-more-header-data sync-pages - decode-audio - decode-video - dup player-audio-full? [ - process-audio [ - f over set-player-audio-full? - 0 over set-player-audio-index - ] when - ] when - dup player-video-ready? [ - dup player-video-time over get-time - dup 0.0 < [ - -0.1 > [ process-video ] when - f over set-player-video-ready? - ] [ - drop - ] if - ] when - decode ; - -: free-malloced-objects ( player -- player ) - [ player-op free ] keep - [ player-oy free ] keep - [ player-og free ] keep - [ player-vo free ] keep - [ player-vi free ] keep - [ player-vd free ] keep - [ player-vb free ] keep - [ player-vc free ] keep - [ player-to free ] keep - [ player-ti free ] keep - [ player-tc free ] keep - [ player-td free ] keep ; - - -: unqueue-openal-buffers ( player -- player ) - [ - - num-audio-buffers-processed over player-source rot player-buffer-indexes swapd - alSourceUnqueueBuffers check-error - ] keep ; - -: delete-openal-buffers ( player -- player ) - [ - player-buffers [ - 1 swap alDeleteBuffers check-error - ] each - ] keep ; - -: delete-openal-source ( player -- player ) - [ player-source 1 swap alDeleteSources check-error ] keep ; - -: cleanup ( player -- player ) - free-malloced-objects - unqueue-openal-buffers - delete-openal-buffers - delete-openal-source ; - -: wait-for-sound ( player -- player ) - #! Waits for the openal to finish playing remaining sounds - dup player-source AL_SOURCE_STATE 0 [ alGetSourcei check-error ] keep - *int AL_PLAYING = [ - 100 sleep - wait-for-sound - ] when ; - -TUPLE: theora-gadget player ; - -: ( player -- gadget ) - theora-gadget construct-gadget - [ set-theora-gadget-player ] keep ; - -M: theora-gadget pref-dim* - theora-gadget-player - player-ti dup theora_info-width swap theora_info-height 2array ; - -M: theora-gadget draw-gadget* ( gadget -- ) - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - GL_UNPACK_ALIGNMENT 1 glPixelStorei - [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep - theora-gadget-player player-rgb glDrawPixels ; - -: initialize-gui ( gadget -- ) - "Theora Player" open-window ; - -: play-ogg ( player -- ) - parse-initial-headers - parse-remaining-headers - initialize-decoder - dup player-gadget [ initialize-gui ] when* - [ decode ] try - wait-for-sound - cleanup - drop ; - -: play-vorbis-stream ( stream -- ) - play-ogg ; - -: play-vorbis-file ( filename -- ) - binary play-vorbis-stream ; - -: play-theora-stream ( stream -- ) - - dup over set-player-gadget - play-ogg ; - -: play-theora-file ( filename -- ) - binary play-theora-stream ; - diff --git a/unmaintained/ogg/player/summary.txt b/unmaintained/ogg/player/summary.txt deleted file mode 100644 index d2e32eff61..0000000000 --- a/unmaintained/ogg/player/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Ogg vorbis and theora media player diff --git a/unmaintained/ogg/player/tags.txt b/unmaintained/ogg/player/tags.txt deleted file mode 100644 index 1adb6f1a28..0000000000 --- a/unmaintained/ogg/player/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -audio -video diff --git a/unmaintained/ogg/summary.txt b/unmaintained/ogg/summary.txt deleted file mode 100644 index 3d2b5511c9..0000000000 --- a/unmaintained/ogg/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Ogg media library binding diff --git a/unmaintained/ogg/tags.txt b/unmaintained/ogg/tags.txt deleted file mode 100644 index be30e2cdd4..0000000000 --- a/unmaintained/ogg/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -bindings -audio -video diff --git a/unmaintained/ogg/theora/authors.txt b/unmaintained/ogg/theora/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/ogg/theora/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/ogg/theora/summary.txt b/unmaintained/ogg/theora/summary.txt deleted file mode 100644 index aa5ec1fdf7..0000000000 --- a/unmaintained/ogg/theora/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Ogg Theora video library binding diff --git a/unmaintained/ogg/theora/tags.txt b/unmaintained/ogg/theora/tags.txt deleted file mode 100644 index 2b68b5238a..0000000000 --- a/unmaintained/ogg/theora/tags.txt +++ /dev/null @@ -1 +0,0 @@ -video diff --git a/unmaintained/ogg/theora/theora.factor b/unmaintained/ogg/theora/theora.factor deleted file mode 100644 index 3d73fb8820..0000000000 --- a/unmaintained/ogg/theora/theora.factor +++ /dev/null @@ -1,120 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel system combinators alien alien.syntax ; -IN: ogg.theora - -<< -"theora" { - { [ os winnt? ] [ "theora.dll" ] } - { [ os macosx? ] [ "libtheora.0.dylib" ] } - { [ os unix? ] [ "libtheora.so" ] } -} cond "cdecl" add-library ->> - -LIBRARY: theora - -C-STRUCT: yuv_buffer - { "int" "y_width" } - { "int" "y_height" } - { "int" "y_stride" } - { "int" "uv_width" } - { "int" "uv_height" } - { "int" "uv_stride" } - { "void*" "y" } - { "void*" "u" } - { "void*" "v" } ; - -: OC_CS_UNSPECIFIED ( -- number ) 0 ; inline -: OC_CS_ITU_REC_470M ( -- number ) 1 ; inline -: OC_CS_ITU_REC_470BG ( -- number ) 2 ; inline -: OC_CS_NSPACES ( -- number ) 3 ; inline - -TYPEDEF: int theora_colorspace - -: OC_PF_420 ( -- number ) 0 ; inline -: OC_PF_RSVD ( -- number ) 1 ; inline -: OC_PF_422 ( -- number ) 2 ; inline -: OC_PF_444 ( -- number ) 3 ; inline - -TYPEDEF: int theora_pixelformat - -C-STRUCT: theora_info - { "uint" "width" } - { "uint" "height" } - { "uint" "frame_width" } - { "uint" "frame_height" } - { "uint" "offset_x" } - { "uint" "offset_y" } - { "uint" "fps_numerator" } - { "uint" "fps_denominator" } - { "uint" "aspect_numerator" } - { "uint" "aspect_denominator" } - { "theora_colorspace" "colorspace" } - { "int" "target_bitrate" } - { "int" "quality" } - { "int" "quick_p" } - { "uchar" "version_major" } - { "uchar" "version_minor" } - { "uchar" "version_subminor" } - { "void*" "codec_setup" } - { "int" "dropframes_p" } - { "int" "keyframe_auto_p" } - { "uint" "keyframe_frequency" } - { "uint" "keyframe_frequency_force" } - { "uint" "keyframe_data_target_bitrate" } - { "int" "keyframe_auto_threshold" } - { "uint" "keyframe_mindistance" } - { "int" "noise_sensitivity" } - { "int" "sharpness" } - { "theora_pixelformat" "pixelformat" } ; - -C-STRUCT: theora_state - { "theora_info*" "i" } - { "longlong" "granulepos" } - { "void*" "internal_encode" } - { "void*" "internal_decode" } ; - -C-STRUCT: theora_comment - { "char**" "user_comments" } - { "int*" "comment_lengths" } - { "int" "comments" } - { "char*" "vendor" } ; - -: OC_FAULT ( -- number ) -1 ; inline -: OC_EINVAL ( -- number ) -10 ; inline -: OC_DISABLED ( -- number ) -11 ; inline -: OC_BADHEADER ( -- number ) -20 ; inline -: OC_NOTFORMAT ( -- number ) -21 ; inline -: OC_VERSION ( -- number ) -22 ; inline -: OC_IMPL ( -- number ) -23 ; inline -: OC_BADPACKET ( -- number ) -24 ; inline -: OC_NEWPACKET ( -- number ) -25 ; inline -: OC_DUPFRAME ( -- number ) 1 ; inline - -FUNCTION: char* theora_version_string ( ) ; -FUNCTION: uint theora_version_number ( ) ; -FUNCTION: int theora_encode_init ( theora_state* th, theora_info* ti ) ; -FUNCTION: int theora_encode_YUVin ( theora_state* t, yuv_buffer* yuv ) ; -FUNCTION: int theora_encode_packetout ( theora_state* t, int last_p, ogg_packet* op ) ; -FUNCTION: int theora_encode_header ( theora_state* t, ogg_packet* op ) ; -FUNCTION: int theora_encode_comment ( theora_comment* tc, ogg_packet* op ) ; -FUNCTION: int theora_encode_tables ( theora_state* t, ogg_packet* op ) ; -FUNCTION: int theora_decode_header ( theora_info* ci, theora_comment* cc, ogg_packet* op ) ; -FUNCTION: int theora_decode_init ( theora_state* th, theora_info* c ) ; -FUNCTION: int theora_decode_packetin ( theora_state* th, ogg_packet* op ) ; -FUNCTION: int theora_decode_YUVout ( theora_state* th, yuv_buffer* yuv ) ; -FUNCTION: int theora_packet_isheader ( ogg_packet* op ) ; -FUNCTION: int theora_packet_iskeyframe ( ogg_packet* op ) ; -FUNCTION: int theora_granule_shift ( theora_info* ti ) ; -FUNCTION: longlong theora_granule_frame ( theora_state* th, longlong granulepos ) ; -FUNCTION: double theora_granule_time ( theora_state* th, longlong granulepos ) ; -FUNCTION: void theora_info_init ( theora_info* c ) ; -FUNCTION: void theora_info_clear ( theora_info* c ) ; -FUNCTION: void theora_clear ( theora_state* t ) ; -FUNCTION: void theora_comment_init ( theora_comment* tc ) ; -FUNCTION: void theora_comment_add ( theora_comment* tc, char* comment ) ; -FUNCTION: void theora_comment_add_tag ( theora_comment* tc, char* tag, char* value ) ; -FUNCTION: char* theora_comment_query ( theora_comment* tc, char* tag, int count ) ; -FUNCTION: int theora_comment_query_count ( theora_comment* tc, char* tag ) ; -FUNCTION: void theora_comment_clear ( theora_comment* tc ) ; diff --git a/unmaintained/ogg/vorbis/authors.txt b/unmaintained/ogg/vorbis/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/unmaintained/ogg/vorbis/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/unmaintained/ogg/vorbis/summary.txt b/unmaintained/ogg/vorbis/summary.txt deleted file mode 100644 index 1a8118ffe2..0000000000 --- a/unmaintained/ogg/vorbis/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Ogg Vorbis audio library binding diff --git a/unmaintained/ogg/vorbis/tags.txt b/unmaintained/ogg/vorbis/tags.txt deleted file mode 100644 index d5cc28426a..0000000000 --- a/unmaintained/ogg/vorbis/tags.txt +++ /dev/null @@ -1 +0,0 @@ -audio diff --git a/unmaintained/ogg/vorbis/vorbis.factor b/unmaintained/ogg/vorbis/vorbis.factor deleted file mode 100644 index 5712272ebc..0000000000 --- a/unmaintained/ogg/vorbis/vorbis.factor +++ /dev/null @@ -1,141 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel system combinators alien alien.syntax ogg ; -IN: ogg.vorbis - -<< -"vorbis" { - { [ os winnt? ] [ "vorbis.dll" ] } - { [ os macosx? ] [ "libvorbis.0.dylib" ] } - { [ os unix? ] [ "libvorbis.so" ] } -} cond "cdecl" add-library ->> - -LIBRARY: vorbis - -C-STRUCT: vorbis_info - { "int" "version" } - { "int" "channels" } - { "long" "rate" } - { "long" "bitrate_upper" } - { "long" "bitrate_nominal" } - { "long" "bitrate_lower" } - { "long" "bitrate_window" } - { "void*" "codec_setup"} - ; - -C-STRUCT: vorbis_dsp_state - { "int" "analysisp" } - { "vorbis_info*" "vi" } - { "float**" "pcm" } - { "float**" "pcmret" } - { "int" "pcm_storage" } - { "int" "pcm_current" } - { "int" "pcm_returned" } - { "int" "preextrapolate" } - { "int" "eofflag" } - { "long" "lW" } - { "long" "W" } - { "long" "nW" } - { "long" "centerW" } - { "longlong" "granulepos" } - { "longlong" "sequence" } - { "longlong" "glue_bits" } - { "longlong" "time_bits" } - { "longlong" "floor_bits" } - { "longlong" "res_bits" } - { "void*" "backend_state" } - ; - -C-STRUCT: alloc_chain - { "void*" "ptr" } - { "void*" "next" } - ; - -C-STRUCT: vorbis_block - { "float**" "pcm" } - { "oggpack_buffer" "opb" } - { "long" "lW" } - { "long" "W" } - { "long" "nW" } - { "int" "pcmend" } - { "int" "mode" } - { "int" "eofflag" } - { "longlong" "granulepos" } - { "longlong" "sequence" } - { "vorbis_dsp_state*" "vd" } - { "void*" "localstore" } - { "long" "localtop" } - { "long" "localalloc" } - { "long" "totaluse" } - { "alloc_chain*" "reap" } - { "long" "glue_bits" } - { "long" "time_bits" } - { "long" "floor_bits" } - { "long" "res_bits" } - { "void*" "internal" } - ; - -C-STRUCT: vorbis_comment - { "char**" "usercomments" } - { "int*" "comment_lengths" } - { "int" "comments" } - { "char*" "vendor" } - ; - -FUNCTION: void vorbis_info_init ( vorbis_info* vi ) ; -FUNCTION: void vorbis_info_clear ( vorbis_info* vi ) ; -FUNCTION: int vorbis_info_blocksize ( vorbis_info* vi, int zo ) ; -FUNCTION: void vorbis_comment_init ( vorbis_comment* vc ) ; -FUNCTION: void vorbis_comment_add ( vorbis_comment* vc, char* comment ) ; -FUNCTION: void vorbis_comment_add_tag ( vorbis_comment* vc, char* tag, char* contents ) ; -FUNCTION: char* vorbis_comment_query ( vorbis_comment* vc, char* tag, int count ) ; -FUNCTION: int vorbis_comment_query_count ( vorbis_comment* vc, char* tag ) ; -FUNCTION: void vorbis_comment_clear ( vorbis_comment* vc ) ; -FUNCTION: int vorbis_block_init ( vorbis_dsp_state* v, vorbis_block* vb ) ; -FUNCTION: int vorbis_block_clear ( vorbis_block* vb ) ; -FUNCTION: void vorbis_dsp_clear ( vorbis_dsp_state* v ) ; -FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepos ) ; -FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; -FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ; -FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v, - vorbis_comment* vc, - ogg_packet* op, - ogg_packet* op_comm, - ogg_packet* op_code ) ; -FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ; -FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ; -FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ; -FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ; -FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ; -FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd, - ogg_packet* op ) ; -FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc, - ogg_packet* op ) ; -FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; -FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ; -FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ; -FUNCTION: int vorbis_synthesis_trackonly ( vorbis_block* vb, ogg_packet* op ) ; -FUNCTION: int vorbis_synthesis_blockin ( vorbis_dsp_state* v, vorbis_block* vb ) ; -FUNCTION: int vorbis_synthesis_pcmout ( vorbis_dsp_state* v, float*** pcm ) ; -FUNCTION: int vorbis_synthesis_lapout ( vorbis_dsp_state* v, float*** pcm ) ; -FUNCTION: int vorbis_synthesis_read ( vorbis_dsp_state* v, int samples ) ; -FUNCTION: long vorbis_packet_blocksize ( vorbis_info* vi, ogg_packet* op ) ; -FUNCTION: int vorbis_synthesis_halfrate ( vorbis_info* v, int flag ) ; -FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis_info* v ) ; - -: OV_FALSE ( -- number ) -1 ; inline -: OV_EOF ( -- number ) -2 ; inline -: OV_HOLE ( -- number ) -3 ; inline -: OV_EREAD ( -- number ) -128 ; inline -: OV_EFAULT ( -- number ) -129 ; inline -: OV_EIMPL ( -- number ) -130 ; inline -: OV_EINVAL ( -- number ) -131 ; inline -: OV_ENOTVORBIS ( -- number ) -132 ; inline -: OV_EBADHEADER ( -- number ) -133 ; inline -: OV_EVERSION ( -- number ) -134 ; inline -: OV_ENOTAUDIO ( -- number ) -135 ; inline -: OV_EBADPACKET ( -- number ) -136 ; inline -: OV_EBADLINK ( -- number ) -137 ; inline -: OV_ENOSEEK ( -- number ) -138 ; inline From 61a1625880cc606d56971355c06f27a9d23434a8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Sep 2008 21:35:43 -0500 Subject: [PATCH 13/39] ogg plays but 1) sound is broken and 2) it doesn't recognize EOF anymore, so it hangs at the end --- {extra => unmaintained}/ogg/authors.txt | 0 {extra => unmaintained}/ogg/ogg.factor | 0 {extra => unmaintained}/ogg/player/authors.txt | 0 {extra => unmaintained}/ogg/player/player.factor | 0 {extra => unmaintained}/ogg/player/summary.txt | 0 {extra => unmaintained}/ogg/player/tags.txt | 0 {extra => unmaintained}/ogg/summary.txt | 0 {extra => unmaintained}/ogg/tags.txt | 0 {extra => unmaintained}/ogg/theora/authors.txt | 0 {extra => unmaintained}/ogg/theora/summary.txt | 0 {extra => unmaintained}/ogg/theora/tags.txt | 0 {extra => unmaintained}/ogg/theora/theora.factor | 0 {extra => unmaintained}/ogg/vorbis/authors.txt | 0 {extra => unmaintained}/ogg/vorbis/summary.txt | 0 {extra => unmaintained}/ogg/vorbis/tags.txt | 0 {extra => unmaintained}/ogg/vorbis/vorbis.factor | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/ogg/authors.txt (100%) rename {extra => unmaintained}/ogg/ogg.factor (100%) rename {extra => unmaintained}/ogg/player/authors.txt (100%) rename {extra => unmaintained}/ogg/player/player.factor (100%) rename {extra => unmaintained}/ogg/player/summary.txt (100%) rename {extra => unmaintained}/ogg/player/tags.txt (100%) rename {extra => unmaintained}/ogg/summary.txt (100%) rename {extra => unmaintained}/ogg/tags.txt (100%) rename {extra => unmaintained}/ogg/theora/authors.txt (100%) rename {extra => unmaintained}/ogg/theora/summary.txt (100%) rename {extra => unmaintained}/ogg/theora/tags.txt (100%) rename {extra => unmaintained}/ogg/theora/theora.factor (100%) rename {extra => unmaintained}/ogg/vorbis/authors.txt (100%) rename {extra => unmaintained}/ogg/vorbis/summary.txt (100%) rename {extra => unmaintained}/ogg/vorbis/tags.txt (100%) rename {extra => unmaintained}/ogg/vorbis/vorbis.factor (100%) diff --git a/extra/ogg/authors.txt b/unmaintained/ogg/authors.txt similarity index 100% rename from extra/ogg/authors.txt rename to unmaintained/ogg/authors.txt diff --git a/extra/ogg/ogg.factor b/unmaintained/ogg/ogg.factor similarity index 100% rename from extra/ogg/ogg.factor rename to unmaintained/ogg/ogg.factor diff --git a/extra/ogg/player/authors.txt b/unmaintained/ogg/player/authors.txt similarity index 100% rename from extra/ogg/player/authors.txt rename to unmaintained/ogg/player/authors.txt diff --git a/extra/ogg/player/player.factor b/unmaintained/ogg/player/player.factor similarity index 100% rename from extra/ogg/player/player.factor rename to unmaintained/ogg/player/player.factor diff --git a/extra/ogg/player/summary.txt b/unmaintained/ogg/player/summary.txt similarity index 100% rename from extra/ogg/player/summary.txt rename to unmaintained/ogg/player/summary.txt diff --git a/extra/ogg/player/tags.txt b/unmaintained/ogg/player/tags.txt similarity index 100% rename from extra/ogg/player/tags.txt rename to unmaintained/ogg/player/tags.txt diff --git a/extra/ogg/summary.txt b/unmaintained/ogg/summary.txt similarity index 100% rename from extra/ogg/summary.txt rename to unmaintained/ogg/summary.txt diff --git a/extra/ogg/tags.txt b/unmaintained/ogg/tags.txt similarity index 100% rename from extra/ogg/tags.txt rename to unmaintained/ogg/tags.txt diff --git a/extra/ogg/theora/authors.txt b/unmaintained/ogg/theora/authors.txt similarity index 100% rename from extra/ogg/theora/authors.txt rename to unmaintained/ogg/theora/authors.txt diff --git a/extra/ogg/theora/summary.txt b/unmaintained/ogg/theora/summary.txt similarity index 100% rename from extra/ogg/theora/summary.txt rename to unmaintained/ogg/theora/summary.txt diff --git a/extra/ogg/theora/tags.txt b/unmaintained/ogg/theora/tags.txt similarity index 100% rename from extra/ogg/theora/tags.txt rename to unmaintained/ogg/theora/tags.txt diff --git a/extra/ogg/theora/theora.factor b/unmaintained/ogg/theora/theora.factor similarity index 100% rename from extra/ogg/theora/theora.factor rename to unmaintained/ogg/theora/theora.factor diff --git a/extra/ogg/vorbis/authors.txt b/unmaintained/ogg/vorbis/authors.txt similarity index 100% rename from extra/ogg/vorbis/authors.txt rename to unmaintained/ogg/vorbis/authors.txt diff --git a/extra/ogg/vorbis/summary.txt b/unmaintained/ogg/vorbis/summary.txt similarity index 100% rename from extra/ogg/vorbis/summary.txt rename to unmaintained/ogg/vorbis/summary.txt diff --git a/extra/ogg/vorbis/tags.txt b/unmaintained/ogg/vorbis/tags.txt similarity index 100% rename from extra/ogg/vorbis/tags.txt rename to unmaintained/ogg/vorbis/tags.txt diff --git a/extra/ogg/vorbis/vorbis.factor b/unmaintained/ogg/vorbis/vorbis.factor similarity index 100% rename from extra/ogg/vorbis/vorbis.factor rename to unmaintained/ogg/vorbis/vorbis.factor From 83aa1ccb68bf411f22c69147eebef187c42d705e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Sep 2008 22:11:03 -0500 Subject: [PATCH 14/39] Checking in new codegen --- unfinished/compiler/alien/alien.factor | 46 ++ .../compiler/backend/alien/alien.factor | 281 ++++++++++ unfinished/compiler/backend/backend.factor | 10 + unfinished/compiler/backend/x86/32/32.factor | 10 + .../{cfg => cfg.bluesky}/alias/alias.factor | 0 .../compiler/{cfg => cfg.bluesky}/authors.txt | 0 .../cfg.bluesky/builder/builder-tests.factor | 4 + .../cfg.bluesky/builder/builder.factor | 256 +++++++++ unfinished/compiler/cfg.bluesky/cfg.factor | 47 ++ .../elaboration/elaboration.factor | 0 .../kill-nops/kill-nops.factor | 0 .../live-ranges/live-ranges.factor | 0 .../predecessors/predecessors.factor | 0 .../simplifier/simplifier.factor | 0 .../{cfg => cfg.bluesky}/stack/stack.factor | 0 .../compiler/{cfg => cfg.bluesky}/summary.txt | 0 .../vn/conditions/conditions.factor | 0 .../vn/constant-fold/constant-fold.factor | 0 .../vn/expressions/expressions.factor | 0 .../vn/graph/graph.factor | 0 .../vn/liveness/liveness.factor | 0 .../vn/propagate/propagate.factor | 0 .../vn/simplify/simplify.factor | 0 .../{cfg => cfg.bluesky}/vn/vn.factor | 0 .../write-barrier/write-barrier.factor | 0 unfinished/compiler/cfg/builder/authors.txt | 1 + .../compiler/cfg/builder/builder-tests.factor | 45 +- .../compiler/cfg/builder/builder.factor | 495 ++++++++++-------- unfinished/compiler/cfg/builder/summary.txt | 1 + unfinished/compiler/cfg/builder/tags.txt | 1 + unfinished/compiler/cfg/cfg.factor | 20 +- .../compiler/cfg/iterator/iterator.factor | 48 ++ unfinished/compiler/cfg/stacks/authors.txt | 1 + unfinished/compiler/cfg/stacks/stacks.factor | 389 ++++++++++++++ .../compiler/cfg/templates/templates.factor | 103 ++++ unfinished/compiler/codegen/fixup/authors.txt | 1 + .../compiler/codegen/fixup/fixup.factor | 154 ++++++ unfinished/compiler/codegen/fixup/summary.txt | 1 + .../compiler/instructions/instructions.factor | 72 +++ .../instructions/syntax/syntax.factor | 15 + .../{lvops => lvops.bluesky}/lvops.factor | 0 .../machine.bluesky/builder/builder.factor | 50 ++ .../debugger/debugger.factor | 0 .../simplifier/simplifier.factor | 0 .../compiler/machine/builder/builder.factor | 58 +- .../linear-scan/allocation/allocation.factor | 90 ++++ .../machine/linear-scan/linear-scan.factor | 12 + .../live-intervals/live-intervals.factor | 32 ++ unfinished/compiler/machine/machine.factor | 27 + .../machine/optimizer/optimizer-tests.factor | 4 + .../machine/optimizer/optimizer.factor | 39 ++ .../compiler/registers/registers.factor | 90 ++++ .../builder/builder.factor | 0 .../{vops => vops.bluesky}/vops.factor | 0 54 files changed, 2145 insertions(+), 258 deletions(-) create mode 100644 unfinished/compiler/alien/alien.factor create mode 100644 unfinished/compiler/backend/alien/alien.factor create mode 100644 unfinished/compiler/backend/backend.factor create mode 100644 unfinished/compiler/backend/x86/32/32.factor rename unfinished/compiler/{cfg => cfg.bluesky}/alias/alias.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/authors.txt (100%) create mode 100644 unfinished/compiler/cfg.bluesky/builder/builder-tests.factor create mode 100644 unfinished/compiler/cfg.bluesky/builder/builder.factor create mode 100644 unfinished/compiler/cfg.bluesky/cfg.factor rename unfinished/compiler/{cfg => cfg.bluesky}/elaboration/elaboration.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/kill-nops/kill-nops.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/live-ranges/live-ranges.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/predecessors/predecessors.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/simplifier/simplifier.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/stack/stack.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/summary.txt (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/conditions/conditions.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/constant-fold/constant-fold.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/expressions/expressions.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/graph/graph.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/liveness/liveness.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/propagate/propagate.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/simplify/simplify.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/vn/vn.factor (100%) rename unfinished/compiler/{cfg => cfg.bluesky}/write-barrier/write-barrier.factor (100%) create mode 100644 unfinished/compiler/cfg/builder/authors.txt mode change 100644 => 100755 unfinished/compiler/cfg/builder/builder.factor create mode 100644 unfinished/compiler/cfg/builder/summary.txt create mode 100644 unfinished/compiler/cfg/builder/tags.txt create mode 100644 unfinished/compiler/cfg/iterator/iterator.factor create mode 100644 unfinished/compiler/cfg/stacks/authors.txt create mode 100755 unfinished/compiler/cfg/stacks/stacks.factor create mode 100644 unfinished/compiler/cfg/templates/templates.factor create mode 100644 unfinished/compiler/codegen/fixup/authors.txt create mode 100755 unfinished/compiler/codegen/fixup/fixup.factor create mode 100644 unfinished/compiler/codegen/fixup/summary.txt create mode 100644 unfinished/compiler/instructions/instructions.factor create mode 100644 unfinished/compiler/instructions/syntax/syntax.factor rename unfinished/compiler/{lvops => lvops.bluesky}/lvops.factor (100%) create mode 100644 unfinished/compiler/machine.bluesky/builder/builder.factor rename unfinished/compiler/{machine => machine.bluesky}/debugger/debugger.factor (100%) rename unfinished/compiler/{machine => machine.bluesky}/simplifier/simplifier.factor (100%) create mode 100644 unfinished/compiler/machine/linear-scan/allocation/allocation.factor create mode 100644 unfinished/compiler/machine/linear-scan/linear-scan.factor create mode 100644 unfinished/compiler/machine/linear-scan/live-intervals/live-intervals.factor create mode 100644 unfinished/compiler/machine/machine.factor create mode 100644 unfinished/compiler/machine/optimizer/optimizer-tests.factor create mode 100644 unfinished/compiler/machine/optimizer/optimizer.factor create mode 100644 unfinished/compiler/registers/registers.factor rename unfinished/compiler/{vops => vops.bluesky}/builder/builder.factor (100%) rename unfinished/compiler/{vops => vops.bluesky}/vops.factor (100%) diff --git a/unfinished/compiler/alien/alien.factor b/unfinished/compiler/alien/alien.factor new file mode 100644 index 0000000000..1d63a06057 --- /dev/null +++ b/unfinished/compiler/alien/alien.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel namespaces make math sequences layouts +alien.c-types alien.structs compiler.backend ; +IN: compiler.alien + +! Common utilities + +: large-struct? ( ctype -- ? ) + dup c-struct? [ + heap-size struct-small-enough? not + ] [ drop f ] if ; + +: alien-parameters ( params -- seq ) + dup parameters>> + swap return>> large-struct? [ "void*" prefix ] when ; + +: alien-return ( params -- ctype ) + return>> dup large-struct? [ drop "void" ] when ; + +: c-type-stack-align ( type -- align ) + dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ; + +: parameter-align ( n type -- n delta ) + over >r c-type-stack-align align dup r> - ; + +: parameter-sizes ( types -- total offsets ) + #! Compute stack frame locations. + [ + 0 [ + [ parameter-align drop dup , ] keep stack-size + + ] reduce cell align + ] { } make ; + +: return-size ( ctype -- n ) + #! Amount of space we reserve for a return value. + dup large-struct? [ heap-size ] [ drop 0 ] if ; + +: alien-stack-frame ( params -- n ) + alien-parameters parameter-sizes drop ; + +: alien-invoke-frame ( params -- n ) + #! One cell is temporary storage, temp@ + dup return>> return-size + swap alien-stack-frame + + cell + ; diff --git a/unfinished/compiler/backend/alien/alien.factor b/unfinished/compiler/backend/alien/alien.factor new file mode 100644 index 0000000000..0c5a6afb75 --- /dev/null +++ b/unfinished/compiler/backend/alien/alien.factor @@ -0,0 +1,281 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.backend.alien + +! #alien-invoke +: set-stack-frame ( n -- ) + dup [ frame-required ] when* \ stack-frame set ; + +: with-stack-frame ( n quot -- ) + swap set-stack-frame + call + f set-stack-frame ; inline + +GENERIC: reg-size ( register-class -- n ) + +M: int-regs reg-size drop cell ; + +M: single-float-regs reg-size drop 4 ; + +M: double-float-regs reg-size drop 8 ; + +GENERIC: reg-class-variable ( register-class -- symbol ) + +M: reg-class reg-class-variable ; + +M: float-regs reg-class-variable drop float-regs ; + +GENERIC: inc-reg-class ( register-class -- ) + +M: reg-class inc-reg-class + dup reg-class-variable inc + fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; + +M: float-regs inc-reg-class + dup call-next-method + fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; + +GENERIC: reg-class-full? ( class -- ? ) + +M: stack-params reg-class-full? drop t ; + +M: object reg-class-full? + [ reg-class-variable get ] [ param-regs length ] bi >= ; + +: spill-param ( reg-class -- n reg-class ) + stack-params get + >r reg-size stack-params +@ r> + stack-params ; + +: fastcall-param ( reg-class -- n reg-class ) + [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ; + +: alloc-parameter ( parameter -- reg reg-class ) + c-type-reg-class dup reg-class-full? + [ spill-param ] [ fastcall-param ] if + [ param-reg ] keep ; + +: (flatten-int-type) ( size -- ) + cell /i "void*" c-type % ; + +GENERIC: flatten-value-type ( type -- ) + +M: object flatten-value-type , ; + +M: struct-type flatten-value-type ( type -- ) + stack-size cell align (flatten-int-type) ; + +M: long-long-type flatten-value-type ( type -- ) + stack-size cell align (flatten-int-type) ; + +: flatten-value-types ( params -- params ) + #! Convert value type structs to consecutive void*s. + [ + 0 [ + c-type + [ parameter-align (flatten-int-type) ] keep + [ stack-size cell align + ] keep + flatten-value-type + ] reduce drop + ] { } make ; + +: each-parameter ( parameters quot -- ) + >r [ parameter-sizes nip ] keep r> 2each ; inline + +: reverse-each-parameter ( parameters quot -- ) + >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline + +: reset-freg-counts ( -- ) + { int-regs float-regs stack-params } [ 0 swap set ] each ; + +: with-param-regs ( quot -- ) + #! In quot you can call alloc-parameter + [ reset-freg-counts call ] with-scope ; inline + +: move-parameters ( node word -- ) + #! Moves values from C stack to registers (if word is + #! %load-param-reg) and registers to C stack (if word is + #! %save-param-reg). + >r + alien-parameters + flatten-value-types + r> [ >r alloc-parameter r> execute ] curry each-parameter ; + inline + +: unbox-parameters ( offset node -- ) + parameters>> [ + %prepare-unbox >r over + r> unbox-parameter + ] reverse-each-parameter drop ; + +: prepare-box-struct ( node -- offset ) + #! Return offset on C stack where to store unboxed + #! parameters. If the C function is returning a structure, + #! the first parameter is an implicit target area pointer, + #! so we need to use a different offset. + return>> dup large-struct? + [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ; + +: objects>registers ( params -- ) + #! Generate code for unboxing a list of C types, then + #! generate code for moving these parameters to register on + #! architectures where parameters are passed in registers. + [ + [ prepare-box-struct ] keep + [ unbox-parameters ] keep + \ %load-param-reg move-parameters + ] with-param-regs ; + +: box-return* ( node -- ) + return>> [ ] [ box-return ] if-void ; + +TUPLE: no-such-library name ; + +M: no-such-library summary + drop "Library not found" ; + +M: no-such-library compiler-error-type + drop +linkage+ ; + +: no-such-library ( name -- ) + \ no-such-library boa + compiling-word get compiler-error ; + +TUPLE: no-such-symbol name ; + +M: no-such-symbol summary + drop "Symbol not found" ; + +M: no-such-symbol compiler-error-type + drop +linkage+ ; + +: no-such-symbol ( name -- ) + \ no-such-symbol boa + compiling-word get compiler-error ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd [ dlsym ] curry contains? + [ drop ] [ no-such-symbol ] if + ] [ + dll-path no-such-library drop + ] if ; + +: stdcall-mangle ( symbol node -- symbol ) + "@" + swap parameters>> parameter-sizes drop + number>string 3append ; + +: alien-invoke-dlsym ( params -- symbols dll ) + dup function>> dup pick stdcall-mangle 2array + swap library>> library dup [ dll>> ] when + 2dup check-dlsym ; + +M: #alien-invoke generate-node + params>> + dup alien-invoke-frame [ + end-basic-block + %prepare-alien-invoke + dup objects>registers + %prepare-var-args + dup alien-invoke-dlsym %alien-invoke + dup %cleanup + box-return* + iterate-next + ] with-stack-frame ; + +! #alien-indirect +M: #alien-indirect generate-node + params>> + dup alien-invoke-frame [ + ! Flush registers + end-basic-block + ! Save registers for GC + %prepare-alien-invoke + ! Save alien at top of stack to temporary storage + %prepare-alien-indirect + dup objects>registers + %prepare-var-args + ! Call alien in temporary storage + %alien-indirect + dup %cleanup + box-return* + iterate-next + ] with-stack-frame ; + +! #alien-callback +: box-parameters ( params -- ) + alien-parameters [ box-parameter ] each-parameter ; + +: registers>objects ( node -- ) + [ + dup \ %save-param-reg move-parameters + "nest_stacks" f %alien-invoke + box-parameters + ] with-param-regs ; + +TUPLE: callback-context ; + +: current-callback 2 getenv ; + +: wait-to-return ( token -- ) + dup current-callback eq? [ + drop + ] [ + yield wait-to-return + ] if ; + +: do-callback ( quot token -- ) + init-catchstack + dup 2 setenv + slip + wait-to-return ; inline + +: callback-return-quot ( ctype -- quot ) + return>> { + { [ dup "void" = ] [ drop [ ] ] } + { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } + [ c-type c-type-unboxer-quot ] + } cond ; + +: callback-prep-quot ( params -- quot ) + parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; + +: wrap-callback-quot ( params -- quot ) + [ + [ callback-prep-quot ] + [ quot>> ] + [ callback-return-quot ] tri 3append , + [ callback-context new do-callback ] % + ] [ ] make ; + +: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; + +: callback-unwind ( params -- n ) + { + { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup return>> large-struct? ] [ drop 4 ] } + [ drop 0 ] + } cond ; + +: %callback-return ( params -- ) + #! All the extra book-keeping for %unwind is only for x86. + #! On other platforms its an alias for %return. + dup alien-return + [ %unnest-stacks ] [ %callback-value ] if-void + callback-unwind %unwind ; + +: generate-callback ( params -- ) + dup xt>> dup [ + init-templates + %prologue + dup alien-stack-frame [ + [ registers>objects ] + [ wrap-callback-quot %alien-callback ] + [ %callback-return ] + tri + ] with-stack-frame + ] with-cfg-builder ; + +M: #alien-callback generate-node + end-basic-block + params>> generate-callback iterate-next ; diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor new file mode 100644 index 0000000000..c1944eb9a7 --- /dev/null +++ b/unfinished/compiler/backend/backend.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system ; +IN: compiler.backend + +! Is this structure small enough to be returned in registers? +HOOK: struct-small-enough? cpu ( size -- ? ) + +! Mapping from register class to machine registers +HOOK: machine-registers cpu ( -- assoc ) diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor new file mode 100644 index 0000000000..85df673839 --- /dev/null +++ b/unfinished/compiler/backend/x86/32/32.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system cpu.x86.assembler compiler.registers compiler.backend ; +IN: compiler.backend.x86.32 + +M: x86.32 machine-registers + { + { int-regs { EAX ECX EDX EBP EBX } } + { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } + } ; diff --git a/unfinished/compiler/cfg/alias/alias.factor b/unfinished/compiler/cfg.bluesky/alias/alias.factor similarity index 100% rename from unfinished/compiler/cfg/alias/alias.factor rename to unfinished/compiler/cfg.bluesky/alias/alias.factor diff --git a/unfinished/compiler/cfg/authors.txt b/unfinished/compiler/cfg.bluesky/authors.txt similarity index 100% rename from unfinished/compiler/cfg/authors.txt rename to unfinished/compiler/cfg.bluesky/authors.txt diff --git a/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor b/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor new file mode 100644 index 0000000000..098919c868 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.cfg.builder.tests +USING: compiler.cfg.builder tools.test ; + +\ build-cfg must-infer diff --git a/unfinished/compiler/cfg.bluesky/builder/builder.factor b/unfinished/compiler/cfg.bluesky/builder/builder.factor new file mode 100644 index 0000000000..76a1b67dd2 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/builder/builder.factor @@ -0,0 +1,256 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel assocs sequences sequences.lib fry accessors +namespaces math combinators math.order +compiler.tree +compiler.tree.combinators +compiler.tree.propagation.info +compiler.cfg +compiler.vops +compiler.vops.builder ; +IN: compiler.cfg.builder + +! Convert tree SSA IR to CFG SSA IR. + +! We construct the graph and set successors first, then we +! set predecessors in a separate pass. This simplifies the +! logic. + +SYMBOL: procedures + +SYMBOL: loop-nesting + +SYMBOL: values>vregs + +GENERIC: convert ( node -- ) + +M: #introduce convert drop ; + +: init-builder ( -- ) + H{ } clone values>vregs set ; + +: end-basic-block ( -- ) + basic-block get [ %b emit ] when ; + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi ; + +: begin-basic-block ( -- ) + basic-block get + [ + end-basic-block + dupd successors>> push + ] when* + set-basic-block ; + +: convert-nodes ( node -- ) + [ convert ] each ; + +: (build-cfg) ( node word -- ) + init-builder + begin-basic-block + basic-block get swap procedures get set-at + convert-nodes ; + +: build-cfg ( node word -- procedures ) + H{ } clone [ + procedures [ (build-cfg) ] with-variable + ] keep ; + +: value>vreg ( value -- vreg ) + values>vregs get at ; + +: output-vreg ( value vreg -- ) + swap values>vregs get set-at ; + +: produce-vreg ( value -- vreg ) + next-vreg [ output-vreg ] keep ; + +: (load-inputs) ( seq stack -- ) + over empty? [ 2drop ] [ + [ ] dip + [ '[ produce-vreg _ , %peek emit ] each-index ] + [ [ length neg ] dip %height emit ] + 2bi + ] if ; + +: load-in-d ( node -- ) in-d>> %data (load-inputs) ; + +: load-in-r ( node -- ) in-r>> %retain (load-inputs) ; + +: (store-outputs) ( seq stack -- ) + over empty? [ 2drop ] [ + [ ] dip + [ [ length ] dip %height emit ] + [ '[ value>vreg _ , %replace emit ] each-index ] + 2bi + ] if ; + +: store-out-d ( node -- ) out-d>> %data (store-outputs) ; + +: store-out-r ( node -- ) out-r>> %retain (store-outputs) ; + +: (emit-call) ( word -- ) + begin-basic-block %call emit begin-basic-block ; + +: intrinsic-inputs ( node -- ) + [ load-in-d ] + [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ] + bi ; + +: intrinsic-outputs ( node -- ) + [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ] + [ store-out-d ] + bi ; + +: intrinsic ( node quot -- ) + [ + init-intrinsic + + [ intrinsic-inputs ] + swap + [ intrinsic-outputs ] + tri + ] with-scope ; inline + +USING: kernel.private math.private slots.private ; + +: maybe-emit-fixnum-shift-fast ( node -- node ) + dup dup in-d>> second node-value-info literal>> dup fixnum? [ + '[ , emit-fixnum-shift-fast ] intrinsic + ] [ + drop dup word>> (emit-call) + ] if ; + +: emit-call ( node -- ) + dup word>> { + { \ tag [ [ emit-tag ] intrinsic ] } + + { \ slot [ [ dup emit-slot ] intrinsic ] } + { \ set-slot [ [ dup emit-set-slot ] intrinsic ] } + + { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] } + { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] } + { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] } + { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] } + { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] } + { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] } + { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] } + { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] } + { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] } + { \ fixnum< [ [ emit-fixnum< ] intrinsic ] } + { \ fixnum> [ [ emit-fixnum> ] intrinsic ] } + { \ eq? [ [ emit-eq? ] intrinsic ] } + + { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] } + + { \ float+ [ [ emit-float+ ] intrinsic ] } + { \ float- [ [ emit-float- ] intrinsic ] } + { \ float* [ [ emit-float* ] intrinsic ] } + { \ float/f [ [ emit-float/f ] intrinsic ] } + { \ float<= [ [ emit-float<= ] intrinsic ] } + { \ float>= [ [ emit-float>= ] intrinsic ] } + { \ float< [ [ emit-float< ] intrinsic ] } + { \ float> [ [ emit-float> ] intrinsic ] } + { \ float? [ [ emit-float= ] intrinsic ] } + + ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } + ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } + ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } + + [ (emit-call) ] + } case drop ; + +M: #call convert emit-call ; + +: emit-call-loop ( #recursive -- ) + dup label>> loop-nesting get at basic-block get successors>> push + end-basic-block + basic-block off + drop ; + +: emit-call-recursive ( #recursive -- ) + label>> id>> (emit-call) ; + +M: #call-recursive convert + dup label>> loop?>> + [ emit-call-loop ] [ emit-call-recursive ] if ; + +M: #push convert + [ + [ out-d>> first produce-vreg ] + [ node-output-infos first literal>> ] + bi emit-literal + ] + [ store-out-d ] bi ; + +M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ; + +M: #>r convert [ load-in-d ] [ store-out-r ] bi ; + +M: #r> convert [ load-in-r ] [ store-out-d ] bi ; + +M: #terminate convert drop ; + +: integer-conditional ( in1 in2 cc -- ) + [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline + +: float-conditional ( in1 in2 branch -- ) + [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline + +: emit-if ( #if -- ) + in-d>> first value>vreg + next-vreg dup f emit-literal + cc/= integer-conditional ; + +: convert-nested ( node -- last-bb ) + [ + + [ set-basic-block ] keep + [ convert-nodes end-basic-block ] dip + basic-block get + ] with-scope + [ basic-block get successors>> push ] dip ; + +: convert-if-children ( #if -- ) + children>> [ convert-nested ] map sift + + [ '[ , _ successors>> push ] each ] + [ set-basic-block ] + bi ; + +M: #if convert + [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ; + +M: #dispatch convert + "Unimplemented" throw ; + +M: #phi convert drop ; + +M: #declare convert drop ; + +M: #return convert drop %return emit ; + +: convert-recursive ( #recursive -- ) + [ [ label>> id>> ] [ child>> ] bi (build-cfg) ] + [ (emit-call) ] + bi ; + +: begin-loop ( #recursive -- ) + label>> basic-block get 2array loop-nesting get push ; + +: end-loop ( -- ) + loop-nesting get pop* ; + +: convert-loop ( #recursive -- ) + begin-basic-block + [ begin-loop ] + [ child>> convert-nodes ] + [ drop end-loop ] + tri ; + +M: #recursive convert + dup label>> loop?>> + [ convert-loop ] [ convert-recursive ] if ; + +M: #copy convert drop ; diff --git a/unfinished/compiler/cfg.bluesky/cfg.factor b/unfinished/compiler/cfg.bluesky/cfg.factor new file mode 100644 index 0000000000..ae14f3e009 --- /dev/null +++ b/unfinished/compiler/cfg.bluesky/cfg.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces assocs sequences sets fry ; +IN: compiler.cfg + +! The id is a globally unique id used for fast hashcode* and +! equal? on basic blocks. The number is assigned by +! linearization. +TUPLE: basic-block < identity-tuple +id +number +instructions +successors +predecessors +stack-frame ; + +SYMBOL: next-block-id + +: ( -- basic-block ) + basic-block new + next-block-id counter >>id + V{ } clone >>instructions + V{ } clone >>successors + V{ } clone >>predecessors ; + +M: basic-block hashcode* id>> nip ; + +! Utilities +SYMBOL: visited-blocks + +: visit-block ( basic-block quot -- ) + over visited-blocks get 2dup key? + [ 2drop 2drop ] [ conjoin call ] if ; inline + +: (each-block) ( basic-block quot -- ) + '[ + , + [ call ] + [ [ successors>> ] dip '[ , (each-block) ] each ] + 2bi + ] visit-block ; inline + +: each-block ( basic-block quot -- ) + H{ } clone visited-blocks [ (each-block) ] with-variable ; inline + +: copy-at ( from to assoc -- ) + 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline diff --git a/unfinished/compiler/cfg/elaboration/elaboration.factor b/unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor similarity index 100% rename from unfinished/compiler/cfg/elaboration/elaboration.factor rename to unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor diff --git a/unfinished/compiler/cfg/kill-nops/kill-nops.factor b/unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor similarity index 100% rename from unfinished/compiler/cfg/kill-nops/kill-nops.factor rename to unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor diff --git a/unfinished/compiler/cfg/live-ranges/live-ranges.factor b/unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor similarity index 100% rename from unfinished/compiler/cfg/live-ranges/live-ranges.factor rename to unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor diff --git a/unfinished/compiler/cfg/predecessors/predecessors.factor b/unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor similarity index 100% rename from unfinished/compiler/cfg/predecessors/predecessors.factor rename to unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor diff --git a/unfinished/compiler/cfg/simplifier/simplifier.factor b/unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor similarity index 100% rename from unfinished/compiler/cfg/simplifier/simplifier.factor rename to unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor diff --git a/unfinished/compiler/cfg/stack/stack.factor b/unfinished/compiler/cfg.bluesky/stack/stack.factor similarity index 100% rename from unfinished/compiler/cfg/stack/stack.factor rename to unfinished/compiler/cfg.bluesky/stack/stack.factor diff --git a/unfinished/compiler/cfg/summary.txt b/unfinished/compiler/cfg.bluesky/summary.txt similarity index 100% rename from unfinished/compiler/cfg/summary.txt rename to unfinished/compiler/cfg.bluesky/summary.txt diff --git a/unfinished/compiler/cfg/vn/conditions/conditions.factor b/unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor similarity index 100% rename from unfinished/compiler/cfg/vn/conditions/conditions.factor rename to unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor diff --git a/unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor b/unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor similarity index 100% rename from unfinished/compiler/cfg/vn/constant-fold/constant-fold.factor rename to unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor diff --git a/unfinished/compiler/cfg/vn/expressions/expressions.factor b/unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor similarity index 100% rename from unfinished/compiler/cfg/vn/expressions/expressions.factor rename to unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor diff --git a/unfinished/compiler/cfg/vn/graph/graph.factor b/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor similarity index 100% rename from unfinished/compiler/cfg/vn/graph/graph.factor rename to unfinished/compiler/cfg.bluesky/vn/graph/graph.factor diff --git a/unfinished/compiler/cfg/vn/liveness/liveness.factor b/unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor similarity index 100% rename from unfinished/compiler/cfg/vn/liveness/liveness.factor rename to unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor diff --git a/unfinished/compiler/cfg/vn/propagate/propagate.factor b/unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor similarity index 100% rename from unfinished/compiler/cfg/vn/propagate/propagate.factor rename to unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor diff --git a/unfinished/compiler/cfg/vn/simplify/simplify.factor b/unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor similarity index 100% rename from unfinished/compiler/cfg/vn/simplify/simplify.factor rename to unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor diff --git a/unfinished/compiler/cfg/vn/vn.factor b/unfinished/compiler/cfg.bluesky/vn/vn.factor similarity index 100% rename from unfinished/compiler/cfg/vn/vn.factor rename to unfinished/compiler/cfg.bluesky/vn/vn.factor diff --git a/unfinished/compiler/cfg/write-barrier/write-barrier.factor b/unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor similarity index 100% rename from unfinished/compiler/cfg/write-barrier/write-barrier.factor rename to unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor diff --git a/unfinished/compiler/cfg/builder/authors.txt b/unfinished/compiler/cfg/builder/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/cfg/builder/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor index 098919c868..ddc7d13f25 100644 --- a/unfinished/compiler/cfg/builder/builder-tests.factor +++ b/unfinished/compiler/cfg/builder/builder-tests.factor @@ -1,4 +1,45 @@ IN: compiler.cfg.builder.tests -USING: compiler.cfg.builder tools.test ; +USING: compiler.cfg.builder tools.test kernel sequences +math.private compiler.tree.builder compiler.tree.optimizer +words sequences.private fry prettyprint alien ; -\ build-cfg must-infer +! Just ensure that various CFGs build correctly. +: test-cfg ( quot -- result ) + build-tree optimize-tree gensym gensym build-cfg ; + +{ + [ ] + [ dup ] + [ swap ] + [ >r r> ] + [ fixnum+ ] + [ fixnum< ] + [ [ 1 ] [ 2 ] if ] + [ fixnum< [ 1 ] [ 2 ] if ] + [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ] + [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ] + [ [ t ] loop ] + [ [ dup ] loop ] + [ [ 2 ] [ 3 throw ] if 4 ] + [ "int" f "malloc" { "int" } alien-invoke ] + [ "int" { "int" } "cdecl" alien-indirect ] + [ "int" { "int" } "cdecl" [ ] alien-callback ] +} [ + '[ _ test-cfg drop ] [ ] swap unit-test +] each + +: test-word-cfg ( word -- result ) + [ build-tree-from-word nip optimize-tree ] keep dup + build-cfg ; + +: test-1 ( -- ) test-1 ; +: test-2 ( -- ) 3 . test-2 ; +: test-3 ( a -- b ) dup [ test-3 ] when ; + +{ + test-1 + test-2 + test-3 +} [ + '[ _ test-word-cfg drop ] [ ] swap unit-test +] each diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor old mode 100644 new mode 100755 index 76a1b67dd2..0e13491a08 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -1,256 +1,295 @@ -! Copyright (C) 2008 Slava Pestov. + ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel assocs sequences sequences.lib fry accessors -namespaces math combinators math.order +USING: accessors arrays assocs combinators hashtables kernel +math fry namespaces make sequences words stack-checker.inlining compiler.tree +compiler.tree.builder compiler.tree.combinators compiler.tree.propagation.info compiler.cfg -compiler.vops -compiler.vops.builder ; +compiler.cfg.stacks +compiler.cfg.templates +compiler.cfg.iterator +compiler.alien +compiler.instructions +compiler.registers ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG SSA IR. - -! We construct the graph and set successors first, then we -! set predecessors in a separate pass. This simplifies the -! logic. - -SYMBOL: procedures - -SYMBOL: loop-nesting - -SYMBOL: values>vregs - -GENERIC: convert ( node -- ) - -M: #introduce convert drop ; - -: init-builder ( -- ) - H{ } clone values>vregs set ; - -: end-basic-block ( -- ) - basic-block get [ %b emit ] when ; +! Convert tree SSA IR to CFG (not quite SSA yet) IR. : set-basic-block ( basic-block -- ) [ basic-block set ] [ instructions>> building set ] bi ; : begin-basic-block ( -- ) - basic-block get - [ - end-basic-block + basic-block get [ dupd successors>> push ] when* set-basic-block ; -: convert-nodes ( node -- ) - [ convert ] each ; +: end-basic-block ( -- ) + building off + basic-block off ; -: (build-cfg) ( node word -- ) - init-builder +USE: qualified +FROM: compiler.generator.registers => +input+ ; +FROM: compiler.generator.registers => +output+ ; +FROM: compiler.generator.registers => +scratch+ ; +FROM: compiler.generator.registers => +clobber+ ; + +SYMBOL: procedures + +SYMBOL: current-word + +SYMBOL: current-label + +SYMBOL: loops + +! Basic block after prologue, makes recursion faster +SYMBOL: current-label-start + +: add-procedure ( -- ) + basic-block get current-word get current-label get + procedures get push ; + +: begin-procedure ( word label -- ) + end-basic-block begin-basic-block - basic-block get swap procedures get set-at - convert-nodes ; + H{ } clone loops set + current-label set + current-word set + add-procedure ; -: build-cfg ( node word -- procedures ) - H{ } clone [ - procedures [ (build-cfg) ] with-variable +: with-cfg-builder ( nodes word label quot -- ) + '[ begin-procedure @ ] with-scope ; inline + +GENERIC: emit-node ( node -- next ) + +: check-basic-block ( node -- node' ) + basic-block get [ drop f ] unless ; inline + +: emit-nodes ( nodes -- ) + [ current-node emit-node check-basic-block ] iterate-nodes + finalize-phantoms ; + +: remember-loop ( label -- ) + basic-block get swap loops get set-at ; + +: begin-word ( -- ) + #! We store the basic block after the prologue as a loop + #! labelled by the current word, so that self-recursive + #! calls can skip an epilogue/prologue. + init-phantoms + %prologue + %branch + begin-basic-block + current-label get remember-loop ; + +: (build-cfg) ( nodes word label -- ) + [ + begin-word + [ emit-nodes ] with-node-iterator + ] with-cfg-builder ; + +: build-cfg ( nodes word label -- procedures ) + V{ } clone [ + procedures [ + (build-cfg) + ] with-variable ] keep ; -: value>vreg ( value -- vreg ) - values>vregs get at ; +: if-intrinsics ( #call -- quot ) + word>> "if-intrinsics" word-prop ; -: output-vreg ( value vreg -- ) - swap values>vregs get set-at ; +: local-recursive-call ( basic-block -- ) + %branch + basic-block get successors>> push + end-basic-block ; -: produce-vreg ( value -- vreg ) - next-vreg [ output-vreg ] keep ; +: emit-call ( word -- next ) + finalize-phantoms + { + { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] } + { [ dup loops get key? ] [ loops get at local-recursive-call f ] } + [ %epilogue %jump f ] + } cond ; -: (load-inputs) ( seq stack -- ) - over empty? [ 2drop ] [ - [ ] dip - [ '[ produce-vreg _ , %peek emit ] each-index ] - [ [ length neg ] dip %height emit ] - 2bi - ] if ; +! #recursive +: compile-recursive ( node -- next ) + [ label>> id>> emit-call ] + [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; -: load-in-d ( node -- ) in-d>> %data (load-inputs) ; - -: load-in-r ( node -- ) in-r>> %retain (load-inputs) ; - -: (store-outputs) ( seq stack -- ) - over empty? [ 2drop ] [ - [ ] dip - [ [ length ] dip %height emit ] - [ '[ value>vreg _ , %replace emit ] each-index ] - 2bi - ] if ; - -: store-out-d ( node -- ) out-d>> %data (store-outputs) ; - -: store-out-r ( node -- ) out-r>> %retain (store-outputs) ; - -: (emit-call) ( word -- ) - begin-basic-block %call emit begin-basic-block ; - -: intrinsic-inputs ( node -- ) - [ load-in-d ] - [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ] - bi ; - -: intrinsic-outputs ( node -- ) - [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ] - [ store-out-d ] - bi ; - -: intrinsic ( node quot -- ) - [ - init-intrinsic - - [ intrinsic-inputs ] - swap - [ intrinsic-outputs ] - tri - ] with-scope ; inline - -USING: kernel.private math.private slots.private ; - -: maybe-emit-fixnum-shift-fast ( node -- node ) - dup dup in-d>> second node-value-info literal>> dup fixnum? [ - '[ , emit-fixnum-shift-fast ] intrinsic - ] [ - drop dup word>> (emit-call) - ] if ; - -: emit-call ( node -- ) - dup word>> { - { \ tag [ [ emit-tag ] intrinsic ] } - - { \ slot [ [ dup emit-slot ] intrinsic ] } - { \ set-slot [ [ dup emit-set-slot ] intrinsic ] } - - { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] } - { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] } - { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] } - { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] } - { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] } - { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] } - { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] } - { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] } - { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] } - { \ fixnum< [ [ emit-fixnum< ] intrinsic ] } - { \ fixnum> [ [ emit-fixnum> ] intrinsic ] } - { \ eq? [ [ emit-eq? ] intrinsic ] } - - { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] } - - { \ float+ [ [ emit-float+ ] intrinsic ] } - { \ float- [ [ emit-float- ] intrinsic ] } - { \ float* [ [ emit-float* ] intrinsic ] } - { \ float/f [ [ emit-float/f ] intrinsic ] } - { \ float<= [ [ emit-float<= ] intrinsic ] } - { \ float>= [ [ emit-float>= ] intrinsic ] } - { \ float< [ [ emit-float< ] intrinsic ] } - { \ float> [ [ emit-float> ] intrinsic ] } - { \ float? [ [ emit-float= ] intrinsic ] } - - ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } - ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } - ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } - - [ (emit-call) ] - } case drop ; - -M: #call convert emit-call ; - -: emit-call-loop ( #recursive -- ) - dup label>> loop-nesting get at basic-block get successors>> push - end-basic-block - basic-block off - drop ; - -: emit-call-recursive ( #recursive -- ) - label>> id>> (emit-call) ; - -M: #call-recursive convert - dup label>> loop?>> - [ emit-call-loop ] [ emit-call-recursive ] if ; - -M: #push convert - [ - [ out-d>> first produce-vreg ] - [ node-output-infos first literal>> ] - bi emit-literal - ] - [ store-out-d ] bi ; - -M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ; - -M: #>r convert [ load-in-d ] [ store-out-r ] bi ; - -M: #r> convert [ load-in-r ] [ store-out-d ] bi ; - -M: #terminate convert drop ; - -: integer-conditional ( in1 in2 cc -- ) - [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline - -: float-conditional ( in1 in2 branch -- ) - [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline - -: emit-if ( #if -- ) - in-d>> first value>vreg - next-vreg dup f emit-literal - cc/= integer-conditional ; - -: convert-nested ( node -- last-bb ) - [ - - [ set-basic-block ] keep - [ convert-nodes end-basic-block ] dip - basic-block get - ] with-scope - [ basic-block get successors>> push ] dip ; - -: convert-if-children ( #if -- ) - children>> [ convert-nested ] map sift - - [ '[ , _ successors>> push ] each ] - [ set-basic-block ] - bi ; - -M: #if convert - [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ; - -M: #dispatch convert - "Unimplemented" throw ; - -M: #phi convert drop ; - -M: #declare convert drop ; - -M: #return convert drop %return emit ; - -: convert-recursive ( #recursive -- ) - [ [ label>> id>> ] [ child>> ] bi (build-cfg) ] - [ (emit-call) ] - bi ; - -: begin-loop ( #recursive -- ) - label>> basic-block get 2array loop-nesting get push ; - -: end-loop ( -- ) - loop-nesting get pop* ; - -: convert-loop ( #recursive -- ) +: compile-loop ( node -- next ) + finalize-phantoms begin-basic-block - [ begin-loop ] - [ child>> convert-nodes ] - [ drop end-loop ] - tri ; + [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi + iterate-next ; -M: #recursive convert - dup label>> loop?>> - [ convert-loop ] [ convert-recursive ] if ; +M: #recursive emit-node + dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; -M: #copy convert drop ; +! #if +: emit-branch ( nodes -- final-bb ) + [ + begin-basic-block copy-phantoms + emit-nodes + basic-block get dup [ %branch ] when + ] with-scope ; + +: emit-if ( node -- next ) + children>> [ emit-branch ] map + end-basic-block + begin-basic-block + basic-block get '[ [ _ swap successors>> push ] when* ] each + init-phantoms + iterate-next ; + +M: #if emit-node + { { f "flag" } } lazy-load first %branch-t + emit-if ; + +! #dispatch +: dispatch-branch ( nodes word -- label ) + gensym [ + [ + copy-phantoms + %prologue + [ emit-nodes ] with-node-iterator + %epilogue + %return + ] with-cfg-builder + ] keep ; + +: dispatch-branches ( node -- ) + children>> [ + current-word get dispatch-branch + %dispatch-label + ] each ; + +: emit-dispatch ( node -- ) + %dispatch dispatch-branches init-phantoms ; + +M: #dispatch emit-node + #! The order here is important, dispatch-branches must + #! run after %dispatch, so that each branch gets the + #! correct register state + tail-call? [ + emit-dispatch iterate-next + ] [ + current-word get gensym [ + [ + begin-word + emit-dispatch + ] with-cfg-builder + ] keep emit-call + ] if ; + +! #call +: define-intrinsics ( word intrinsics -- ) + "intrinsics" set-word-prop ; + +: define-intrinsic ( word quot assoc -- ) + 2array 1array define-intrinsics ; + +: define-if-intrinsics ( word intrinsics -- ) + [ +input+ associate ] assoc-map + "if-intrinsics" set-word-prop ; + +: define-if-intrinsic ( word quot inputs -- ) + 2array 1array define-if-intrinsics ; + +: find-intrinsic ( #call -- pair/f ) + word>> "intrinsics" word-prop find-template ; + +: find-boolean-intrinsic ( #call -- pair/f ) + word>> "if-intrinsics" word-prop find-template ; + +: find-if-intrinsic ( #call -- pair/f ) + node@ { + { [ dup length 2 < ] [ 2drop f ] } + { [ dup second #if? ] [ drop find-boolean-intrinsic ] } + [ 2drop f ] + } cond ; + +: do-if-intrinsic ( pair -- next ) + [ %if-intrinsic ] apply-template skip-next emit-if ; + +: do-boolean-intrinsic ( pair -- next ) + [ + f alloc-vreg [ %boolean-intrinsic ] keep phantom-push + ] apply-template iterate-next ; + +: do-intrinsic ( pair -- next ) + [ %intrinsic ] apply-template iterate-next ; + +: setup-operand-classes ( #call -- ) + node-input-infos [ class>> ] map set-operand-classes ; + +M: #call emit-node + dup setup-operand-classes + dup find-if-intrinsic [ do-if-intrinsic ] [ + dup find-boolean-intrinsic [ do-boolean-intrinsic ] [ + dup find-intrinsic [ do-intrinsic ] [ + word>> emit-call + ] ?if + ] ?if + ] ?if ; + +! #call-recursive +M: #call-recursive emit-node label>> id>> emit-call ; + +! #push +M: #push emit-node + literal>> phantom-push iterate-next ; + +! #shuffle +M: #shuffle emit-node + shuffle-effect phantom-shuffle iterate-next ; + +M: #>r emit-node + [ in-d>> length ] [ out-r>> empty? ] bi + [ phantom-drop ] [ phantom->r ] if + iterate-next ; + +M: #r> emit-node + [ in-r>> length ] [ out-d>> empty? ] bi + [ phantom-rdrop ] [ phantom-r> ] if + iterate-next ; + +! #return +M: #return emit-node + drop finalize-phantoms %epilogue %return f ; + +M: #return-recursive emit-node + finalize-phantoms + label>> id>> loops get key? + [ %epilogue %return ] unless f ; + +! #terminate +M: #terminate emit-node drop end-basic-block f ; + +! FFI +M: #alien-invoke emit-node + params>> + [ alien-invoke-frame %frame-required ] + [ %alien-invoke iterate-next ] + bi ; + +M: #alien-indirect emit-node + params>> + [ alien-invoke-frame %frame-required ] + [ %alien-indirect iterate-next ] + bi ; + +M: #alien-callback emit-node + params>> dup xt>> dup + [ init-phantoms %alien-callback ] with-cfg-builder + iterate-next ; + +! No-op nodes +M: #introduce emit-node drop iterate-next ; + +M: #copy emit-node drop iterate-next ; + +M: #enter-recursive emit-node drop iterate-next ; + +M: #phi emit-node drop iterate-next ; diff --git a/unfinished/compiler/cfg/builder/summary.txt b/unfinished/compiler/cfg/builder/summary.txt new file mode 100644 index 0000000000..cf857ad971 --- /dev/null +++ b/unfinished/compiler/cfg/builder/summary.txt @@ -0,0 +1 @@ +Final stage of compilation generates machine code from dataflow IR diff --git a/unfinished/compiler/cfg/builder/tags.txt b/unfinished/compiler/cfg/builder/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/unfinished/compiler/cfg/builder/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor index ae14f3e009..92a5700af4 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/unfinished/compiler/cfg/cfg.factor @@ -3,16 +3,19 @@ USING: kernel accessors namespaces assocs sequences sets fry ; IN: compiler.cfg -! The id is a globally unique id used for fast hashcode* and -! equal? on basic blocks. The number is assigned by -! linearization. +TUPLE: procedure entry word label ; + +C: procedure + +! - "id" is a globally unique id used for hashcode*. +! - "number" is assigned by linearization. TUPLE: basic-block < identity-tuple id number +label instructions successors -predecessors -stack-frame ; +predecessors ; SYMBOL: next-block-id @@ -34,14 +37,11 @@ SYMBOL: visited-blocks : (each-block) ( basic-block quot -- ) '[ - , + _ [ call ] - [ [ successors>> ] dip '[ , (each-block) ] each ] + [ [ successors>> ] dip '[ _ (each-block) ] each ] 2bi ] visit-block ; inline : each-block ( basic-block quot -- ) H{ } clone visited-blocks [ (each-block) ] with-variable ; inline - -: copy-at ( from to assoc -- ) - 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline diff --git a/unfinished/compiler/cfg/iterator/iterator.factor b/unfinished/compiler/cfg/iterator/iterator.factor new file mode 100644 index 0000000000..904da3f0c3 --- /dev/null +++ b/unfinished/compiler/cfg/iterator/iterator.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences kernel compiler.tree ; +IN: compiler.cfg.iterator + +SYMBOL: node-stack + +: >node ( cursor -- ) node-stack get push ; +: node> ( -- cursor ) node-stack get pop ; +: node@ ( -- cursor ) node-stack get peek ; +: current-node ( -- node ) node@ first ; +: iterate-next ( -- cursor ) node@ rest-slice ; +: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ; + +: iterate-nodes ( cursor quot: ( -- ) -- ) + over empty? [ + 2drop + ] [ + [ swap >node call node> drop ] keep iterate-nodes + ] if ; inline recursive + +: with-node-iterator ( quot -- ) + >r V{ } clone node-stack r> with-variable ; inline + +DEFER: (tail-call?) + +: tail-phi? ( cursor -- ? ) + [ first #phi? ] [ rest-slice (tail-call?) ] bi and ; + +: (tail-call?) ( cursor -- ? ) + [ t ] [ + [ + first + [ #return? ] + [ #return-recursive? ] + [ #terminate? ] tri or or + ] [ tail-phi? ] bi or + ] if-empty ; + +: tail-call? ( -- ? ) + node-stack get [ + rest-slice + [ t ] [ + [ (tail-call?) ] + [ first #terminate? not ] + bi and + ] if-empty + ] all? ; diff --git a/unfinished/compiler/cfg/stacks/authors.txt b/unfinished/compiler/cfg/stacks/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/cfg/stacks/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor new file mode 100755 index 0000000000..f2cfbb70a1 --- /dev/null +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -0,0 +1,389 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs classes classes.private classes.algebra +combinators hashtables kernel layouts math fry namespaces +quotations sequences system vectors words effects alien +byte-arrays accessors sets math.order compiler.instructions +compiler.registers ; +IN: compiler.cfg.stacks + +! Converting stack operations into register operations, while +! doing a bit of optimization along the way. + +USE: qualified +FROM: compiler.generator.registers => +input+ ; +FROM: compiler.generator.registers => +output+ ; +FROM: compiler.generator.registers => +scratch+ ; +FROM: compiler.generator.registers => +clobber+ ; +SYMBOL: known-tag + +! Value protocol +GENERIC: set-operand-class ( class obj -- ) +GENERIC: operand-class* ( operand -- class ) +GENERIC: move-spec ( obj -- spec ) +GENERIC: live-loc? ( actual current -- ? ) +GENERIC# (lazy-load) 1 ( value spec -- value ) +GENERIC# (eager-load) 1 ( value spec -- value ) +GENERIC: lazy-store ( dst src -- ) +GENERIC: minimal-ds-loc* ( min obj -- min ) + +! This will be a multimethod soon +DEFER: %move + +PRIVATE> + +: operand-class ( operand -- class ) + operand-class* object or ; + +! Default implementation +M: value set-operand-class 2drop ; +M: value operand-class* drop f ; +M: value live-loc? 2drop f ; +M: value minimal-ds-loc* drop ; +M: value lazy-store 2drop ; + +M: vreg move-spec reg-class>> move-spec ; + +M: int-regs move-spec drop f ; +M: int-regs operand-class* drop object ; + +M: float-regs move-spec drop float ; +M: float-regs operand-class* drop float ; + +M: ds-loc minimal-ds-loc* n>> min ; +M: ds-loc live-loc? + over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; + +M: rs-loc live-loc? + over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; + +M: loc operand-class* class>> ; +M: loc set-operand-class (>>class) ; +M: loc move-spec drop loc ; + +M: f move-spec drop loc ; +M: f operand-class* ; + +M: cached set-operand-class vreg>> set-operand-class ; +M: cached operand-class* vreg>> operand-class* ; +M: cached move-spec drop cached ; +M: cached live-loc? loc>> live-loc? ; +M: cached (lazy-load) >r vreg>> r> (lazy-load) ; +M: cached (eager-load) >r vreg>> r> (eager-load) ; +M: cached lazy-store + 2dup loc>> live-loc? + [ "live-locs" get at %move ] [ 2drop ] if ; +M: cached minimal-ds-loc* loc>> minimal-ds-loc* ; + +M: tagged set-operand-class (>>class) ; +M: tagged operand-class* class>> ; +M: tagged move-spec drop f ; + +M: unboxed-alien operand-class* drop simple-alien ; +M: unboxed-alien move-spec class ; + +M: unboxed-byte-array operand-class* drop c-ptr ; +M: unboxed-byte-array move-spec class ; + +M: unboxed-f operand-class* drop \ f ; +M: unboxed-f move-spec class ; + +M: unboxed-c-ptr operand-class* drop c-ptr ; +M: unboxed-c-ptr move-spec class ; + +M: constant operand-class* value>> class ; +M: constant move-spec class ; + +! Moving values between locations and registers +: %move-bug ( -- * ) "Bug in generator.registers" throw ; + +: %unbox-c-ptr ( dst src -- ) + dup operand-class { + { [ dup \ f class<= ] [ drop %unbox-f ] } + { [ dup simple-alien class<= ] [ drop %unbox-alien ] } + { [ dup byte-array class<= ] [ drop %unbox-byte-array ] } + [ drop %unbox-any-c-ptr ] + } cond ; inline + +: %move-via-temp ( dst src -- ) + #! For many transfers, such as loc to unboxed-alien, we + #! don't have an intrinsic, so we transfer the source to + #! temp then temp to the destination. + int-regs next-vreg [ over %move operand-class ] keep + tagged new + swap >>vreg + swap >>class + %move ; + +: %move ( dst src -- ) + 2dup [ move-spec ] bi@ 2array { + { { f f } [ %copy ] } + { { unboxed-alien unboxed-alien } [ %copy ] } + { { unboxed-byte-array unboxed-byte-array } [ %copy ] } + { { unboxed-f unboxed-f } [ %copy ] } + { { unboxed-c-ptr unboxed-c-ptr } [ %copy ] } + { { float float } [ %copy-float ] } + + { { f unboxed-c-ptr } [ %move-bug ] } + { { f unboxed-byte-array } [ %move-bug ] } + + { { f constant } [ value>> swap %load-literal ] } + + { { f float } [ %box-float ] } + { { f unboxed-alien } [ %box-alien ] } + { { f loc } [ %peek ] } + + { { float f } [ %unbox-float ] } + { { unboxed-alien f } [ %unbox-alien ] } + { { unboxed-byte-array f } [ %unbox-byte-array ] } + { { unboxed-f f } [ %unbox-f ] } + { { unboxed-c-ptr f } [ %unbox-c-ptr ] } + { { loc f } [ swap %replace ] } + + [ drop %move-via-temp ] + } case ; + +! A compile-time stack +TUPLE: phantom-stack height stack ; + +M: phantom-stack clone + call-next-method [ clone ] change-stack ; + +GENERIC: finalize-height ( stack -- ) + +: new-phantom-stack ( class -- stack ) + >r 0 V{ } clone r> boa ; inline + +: (loc) ( m stack -- n ) + #! Utility for methods on + height>> - ; + +: (finalize-height) ( stack word -- ) + #! We consolidate multiple stack height changes until the + #! last moment, and we emit the final height changing + #! instruction here. + '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline + +GENERIC: ( n stack -- loc ) + +TUPLE: phantom-datastack < phantom-stack ; + +: ( -- stack ) + phantom-datastack new-phantom-stack ; + +M: phantom-datastack (loc) ; + +M: phantom-datastack finalize-height + \ %inc-d (finalize-height) ; + +TUPLE: phantom-retainstack < phantom-stack ; + +: ( -- stack ) + phantom-retainstack new-phantom-stack ; + +M: phantom-retainstack (loc) ; + +M: phantom-retainstack finalize-height + \ %inc-r (finalize-height) ; + +: phantom-locs ( n phantom -- locs ) + #! A sequence of n ds-locs or rs-locs indexing the stack. + >r r> '[ _ ] map ; + +: phantom-locs* ( phantom -- locs ) + [ stack>> length ] keep phantom-locs ; + +: phantoms ( -- phantom phantom ) + phantom-datastack get phantom-retainstack get ; + +: (each-loc) ( phantom quot -- ) + >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline + +: each-loc ( quot -- ) + phantoms 2array swap '[ _ (each-loc) ] each ; inline + +: adjust-phantom ( n phantom -- ) + swap '[ _ + ] change-height drop ; + +: cut-phantom ( n phantom -- seq ) + swap '[ _ cut* swap ] change-stack drop ; + +: phantom-append ( seq stack -- ) + over length over adjust-phantom stack>> push-all ; + +: add-locs ( n phantom -- ) + 2dup stack>> length <= [ + 2drop + ] [ + [ phantom-locs ] keep + [ stack>> length head-slice* ] keep + [ append >vector ] change-stack drop + ] if ; + +: phantom-input ( n phantom -- seq ) + 2dup add-locs + 2dup cut-phantom + >r >r neg r> adjust-phantom r> ; + +: each-phantom ( quot -- ) phantoms rot bi@ ; inline + +: finalize-heights ( -- ) [ finalize-height ] each-phantom ; + +: (live-locs) ( phantom -- seq ) + #! Discard locs which haven't moved + [ phantom-locs* ] [ stack>> ] bi zip + [ live-loc? ] assoc-filter + values ; + +: live-locs ( -- seq ) + [ (live-locs) ] each-phantom append prune ; + +! Operands holding pointers to freshly-allocated objects which +! are guaranteed to be in the nursery +SYMBOL: fresh-objects + +: reg-spec>class ( spec -- class ) + float eq? double-float-regs int-regs ? ; + +: alloc-vreg ( spec -- reg ) + [ reg-spec>class next-vreg ] keep { + { f [ ] } + { unboxed-alien [ ] } + { unboxed-byte-array [ ] } + { unboxed-f [ ] } + { unboxed-c-ptr [ ] } + [ drop ] + } case ; + +: compatible? ( value spec -- ? ) + >r move-spec r> { + { [ 2dup = ] [ t ] } + { [ dup unboxed-c-ptr eq? ] [ + over { unboxed-byte-array unboxed-alien } member? + ] } + [ f ] + } cond 2nip ; + +: alloc-vreg-for ( value spec -- vreg ) + alloc-vreg swap operand-class + over tagged? [ >>class ] [ drop ] if ; + +M: value (lazy-load) + { + { [ dup quotation? ] [ drop ] } + { [ 2dup compatible? ] [ drop ] } + [ (eager-load) ] + } cond ; + +M: value (eager-load) ( value spec -- vreg ) + [ alloc-vreg-for ] [ drop ] 2bi + [ %move ] [ drop ] 2bi ; + +M: loc lazy-store + 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ; + +: finalize-locs ( -- ) + #! Perform any deferred stack shuffling. + live-locs [ dup f (lazy-load) ] H{ } map>assoc + dup assoc-empty? [ drop ] [ + "live-locs" set [ lazy-store ] each-loc + ] if ; + +: finalize-vregs ( -- ) + #! Store any vregs to their final stack locations. + [ + dup loc? over cached? or [ 2drop ] [ %move ] if + ] each-loc ; + +: reset-phantom ( phantom -- ) + #! Kill register assignments but preserve constants and + #! class information. + dup phantom-locs* + over stack>> [ + dup constant? [ nip ] [ + operand-class over set-operand-class + ] if + ] 2map + over stack>> delete-all + swap stack>> push-all ; + +: reset-phantoms ( -- ) + [ reset-phantom ] each-phantom ; + +: finalize-contents ( -- ) + finalize-locs finalize-vregs reset-phantoms ; + +! Loading stacks to vregs +: vreg-substitution ( value vreg -- pair ) + dupd 2array ; + +: substitute-vreg? ( old new -- ? ) + #! We don't substitute locs for float or alien vregs, + #! since in those cases the boxing overhead might kill us. + vreg>> tagged? >r loc? r> and ; + +: substitute-vregs ( values vregs -- ) + [ vreg-substitution ] 2map + [ substitute-vreg? ] assoc-filter >hashtable + '[ stack>> _ substitute-here ] each-phantom ; + +: clear-phantoms ( -- ) + [ stack>> delete-all ] each-phantom ; + +: set-operand-classes ( classes -- ) + phantom-datastack get + over length over add-locs + stack>> [ set-operand-class ] 2reverse-each ; + +: finalize-phantoms ( -- ) + #! Commit all deferred stacking shuffling, and ensure the + #! in-memory data and retain stacks are up to date with + #! respect to the compiler's current picture. + finalize-contents + clear-phantoms + finalize-heights + fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ; + +: fresh-object ( obj -- ) fresh-objects get push ; + +: fresh-object? ( obj -- ? ) fresh-objects get memq? ; + +: init-phantoms ( -- ) + V{ } clone fresh-objects set + phantom-datastack set + phantom-retainstack set ; + +: copy-phantoms ( -- ) + fresh-objects [ clone ] change + phantom-datastack [ clone ] change + phantom-retainstack [ clone ] change ; + +: operand-tag ( operand -- tag/f ) + operand-class dup [ class-tag ] when ; + +UNION: immediate fixnum POSTPONE: f ; + +: operand-immediate? ( operand -- ? ) + operand-class immediate class<= ; + +: phantom-push ( obj -- ) + 1 phantom-datastack get adjust-phantom + phantom-datastack get stack>> push ; + +: phantom-shuffle ( shuffle -- ) + [ in>> length phantom-datastack get phantom-input ] keep + shuffle phantom-datastack get phantom-append ; + +: phantom->r ( n -- ) + phantom-datastack get phantom-input + phantom-retainstack get phantom-append ; + +: phantom-r> ( n -- ) + phantom-retainstack get phantom-input + phantom-datastack get phantom-append ; + +: phantom-drop ( n -- ) + phantom-datastack get phantom-input drop ; + +: phantom-rdrop ( n -- ) + phantom-retainstack get phantom-input drop ; diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor new file mode 100644 index 0000000000..798e1fd563 --- /dev/null +++ b/unfinished/compiler/cfg/templates/templates.factor @@ -0,0 +1,103 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs accessors sequences kernel fry namespaces +quotations combinators classes.algebra compiler.instructions +compiler.registers compiler.cfg.stacks ; +IN: compiler.cfg.templates + +USE: qualified +FROM: compiler.generator.registers => +input+ ; +FROM: compiler.generator.registers => +output+ ; +FROM: compiler.generator.registers => +scratch+ ; +FROM: compiler.generator.registers => +clobber+ ; + +: template-input +input+ swap at ; inline +: template-output +output+ swap at ; inline +: template-scratch +scratch+ swap at ; inline +: template-clobber +clobber+ swap at ; inline + +: phantom&spec ( phantom specs -- phantom' specs' ) + >r stack>> r> + [ length f pad-left ] keep + [ ] bi@ ; inline + +: phantom&spec-agree? ( phantom spec quot -- ? ) + >r phantom&spec r> 2all? ; inline + +: live-vregs ( -- seq ) + [ stack>> [ >vreg ] map sift ] each-phantom append ; + +: clobbered ( template -- seq ) + [ template-output ] [ template-clobber ] bi append ; + +: clobbered? ( value name -- ? ) + \ clobbered get member? [ + >vreg \ live-vregs get member? + ] [ drop f ] if ; + +: lazy-load ( specs -- seq ) + [ length phantom-datastack get phantom-input ] keep + [ drop ] [ + [ + 2dup second clobbered? + [ first (eager-load) ] [ first (lazy-load) ] if + ] 2map + ] 2bi + [ substitute-vregs ] keep ; + +: load-inputs ( template -- assoc ) + [ + live-vregs \ live-vregs set + dup clobbered \ clobbered set + template-input [ values ] [ lazy-load ] bi zip + ] with-scope ; + +: alloc-scratch ( template -- assoc ) + template-scratch [ swap alloc-vreg ] assoc-map ; + +: do-template-inputs ( template -- inputs ) + #! Load input values into registers and allocates scratch + #! registers. + [ load-inputs ] [ alloc-scratch ] bi assoc-union ; + +: do-template-outputs ( template inputs -- ) + [ template-output ] dip '[ _ at ] map + phantom-datastack get phantom-append ; + +: apply-template ( pair quot -- vregs ) + [ + first2 dup do-template-inputs + [ do-template-outputs ] keep + ] dip call ; inline + +: value-matches? ( value spec -- ? ) + #! If the spec is a quotation and the value is a literal + #! fixnum, see if the quotation yields true when applied + #! to the fixnum. Otherwise, the values don't match. If the + #! spec is not a quotation, its a reg-class, in which case + #! the value is always good. + dup quotation? [ + over constant? + [ >r value>> r> 2drop f ] [ 2drop f ] if + ] [ + 2drop t + ] if ; + +: class-matches? ( actual expected -- ? ) + { + { f [ drop t ] } + { known-tag [ dup [ class-tag >boolean ] when ] } + [ class<= ] + } case ; + +: spec-matches? ( value spec -- ? ) + 2dup first value-matches? + >r >r operand-class 2 r> ?nth class-matches? r> and ; + +: template-matches? ( template -- ? ) + template-input phantom-datastack get swap + [ spec-matches? ] phantom&spec-agree? ; + +: find-template ( templates -- pair/f ) + #! Pair has shape { quot assoc } + [ second template-matches? ] find nip ; diff --git a/unfinished/compiler/codegen/fixup/authors.txt b/unfinished/compiler/codegen/fixup/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unfinished/compiler/codegen/fixup/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/unfinished/compiler/codegen/fixup/fixup.factor b/unfinished/compiler/codegen/fixup/fixup.factor new file mode 100755 index 0000000000..1f1cf81cb9 --- /dev/null +++ b/unfinished/compiler/codegen/fixup/fixup.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays generic assocs hashtables io.binary +kernel kernel.private math namespaces make sequences words +quotations strings alien.accessors alien.strings layouts system +combinators math.bitwise words.private cpu.architecture +math.order accessors growable ; +IN: compiler.cfg.fixup + +: no-stack-frame -1 ; inline + +TUPLE: frame-required n ; + +: frame-required ( n -- ) \ frame-required boa , ; + +: stack-frame-size ( code -- n ) + no-stack-frame [ + dup frame-required? [ n>> max ] [ drop ] if + ] reduce ; + +GENERIC: fixup* ( frame-size obj -- frame-size ) + +: code-format 22 getenv ; + +: compiled-offset ( -- n ) building get length code-format * ; + +TUPLE: label offset ; + +: