From 1cd285bcaa8112272ddb46fe641204599c08cbc6 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:14 -0600 Subject: [PATCH 001/170] Slots with declared type of callable or quotation now have an initial value [ ] --- core/slots/slots.factor | 1 + 1 file changed, 1 insertion(+) mode change 100644 => 100755 core/slots/slots.factor diff --git a/core/slots/slots.factor b/core/slots/slots.factor old mode 100644 new mode 100755 index f166378d9d..24ff1b0f8b --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; From 49875b9cc7db5c1c514d0a85f8d3ed0917fc67d9 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:46 -0600 Subject: [PATCH 002/170] Use factor.exe or factor.com when deploying on Windows, depending on whether or not the UI is enabled --- basis/tools/deploy/backend/backend.factor | 2 +- basis/tools/deploy/macosx/macosx.factor | 2 +- basis/tools/deploy/unix/unix.factor | 2 +- basis/tools/deploy/windows/windows.factor | 23 ++++++++++++++--------- 4 files changed, 17 insertions(+), 12 deletions(-) mode change 100644 => 100755 basis/tools/deploy/backend/backend.factor mode change 100644 => 100755 basis/tools/deploy/macosx/macosx.factor mode change 100644 => 100755 basis/tools/deploy/unix/unix.factor diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor old mode 100644 new mode 100755 index 636e44062e..22d6eb2ffa --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -11,7 +11,7 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend -: copy-vm ( executable bundle-name extension -- vm ) +: copy-vm ( executable bundle-name -- vm ) [ prepend-path ] dip append vm over copy-file ; : copy-fonts ( name dir -- ) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 index 91b4d603af..8fe31ac6cc --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -54,7 +54,7 @@ IN: tools.deploy.macosx } cleave ] [ create-app-plist ] - [ "Contents/MacOS/" append-path "" copy-vm ] 2tri + [ "Contents/MacOS/" append-path copy-vm ] 2tri dup OCT: 755 set-file-permissions ; : deploy.app-image ( vocab bundle-name -- str ) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor old mode 100644 new mode 100755 index 9e0bb8ac68..c9bf308357 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -8,7 +8,7 @@ IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm + copy-vm dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7ce635b1ba..0e9146b26e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.directories kernel namespaces sequences system -tools.deploy.backend tools.deploy.config -tools.deploy.config.editor assocs hashtables prettyprint -combinators windows.shell32 windows.user32 ; +USING: io io.files io.pathnames io.directories kernel namespaces +sequences locals system splitting tools.deploy.backend +tools.deploy.config tools.deploy.config.editor assocs hashtables +prettyprint combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dll ( bundle-name -- ) @@ -15,13 +15,18 @@ IN: tools.deploy.windows "resource:zlib1.dll" } swap copy-files-into ; +:: copy-vm ( executable bundle-name extension -- vm ) + vm "." split1-last drop extension append + bundle-name executable ".exe" append append-path + [ copy-file ] keep ; + : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll deploy-ui? get [ - dup copy-freetype - dup "" copy-fonts - ] when - ".exe" copy-vm ; + [ copy-freetype ] + [ "" copy-fonts ] + [ ".exe" copy-vm ] tri + ] [ ".com" copy-vm ] if ; M: winnt deploy* "resource:" [ From 5af6c10eedfd8eb348b04ce5b614495da6dc4469 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:03 -0600 Subject: [PATCH 003/170] Fix io.launcher.windows.nt test when run from factor.exe --- basis/io/launcher/windows/nt/nt-tests.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/io/launcher/windows/nt/nt-tests.factor diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 4dd0eebed3..04202365fd --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests "out.txt" temp-file ascii file-lines first ] unit-test -[ ] [ +[ "( scratchpad ) " ] [ console-vm "-run=listener" 2array >>command +closed+ >>stdin - try-process + +stdout+ >>stderr + ascii [ input-stream get contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test + + From a4a6885189bb7a432d4c78638975f7b6a1c9564d Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:57 -0600 Subject: [PATCH 004/170] Fix setters for value struct slots and add unit test for this case; this fixes an io.mmap regression on Windows --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 26 +++++++++++++----------- basis/alien/structs/structs-tests.factor | 15 ++++++++++++++ basis/alien/structs/structs.factor | 12 +++++++++-- 4 files changed, 40 insertions(+), 15 deletions(-) mode change 100644 => 100755 basis/alien/arrays/arrays.factor mode change 100644 => 100755 basis/alien/c-types/c-types.factor mode change 100644 => 100755 basis/alien/structs/structs-tests.factor mode change 100644 => 100755 basis/alien/structs/structs.factor diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor old mode 100644 new mode 100755 index 8253d9458c..6a182f8dbf --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop f ; +M: array c-type-boxer-quot drop [ ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor old mode 100644 new mode 100755 index a4bc3d3f52..a44b5cf2b6 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math 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 fry call ; +accessors combinators effects continuations fry call classes ; IN: alien.c-types DEFER: @@ -13,18 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -class -boxer boxer-quot unboxer unboxer-quot -getter setter -reg-class size align stack-align? ; - -: new-c-type ( class -- type ) - new - int-regs >>reg-class - object >>class ; inline +{ class class initial: object } +boxer +{ boxer-quot callable } +unboxer +{ unboxer-quot callable } +{ getter callable } +{ setter callable } +{ reg-class initial: int-regs } +size +align +stack-align? ; : ( -- type ) - \ c-type new-c-type ; + \ c-type new ; SYMBOL: c-types @@ -224,7 +226,7 @@ M: f byte-length drop 0 ; TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type new-c-type ; + long-long-type new ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor old mode 100644 new mode 100755 index ec0c01c2e7..8bc570c448 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -42,3 +42,18 @@ C-UNION: barx [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when + +C-STRUCT: nested + { "int" "x" } ; + +C-STRUCT: nested-2 + { "nested" "y" } ; + +[ 4 ] [ + "nested-2" + "nested" + 4 over set-nested-x + over set-nested-2-y + nested-2-y + nested-x +] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor old mode 100644 new mode 100755 index 698518b4e5..8ec694198d --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -2,10 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order ; +alien.c-types alien.structs.fields cpu.architecture math.order +quotations ; IN: alien.structs -TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; +TUPLE: struct-type +size +align +fields +{ boxer-quot callable } +{ unboxer-quot callable } +{ getter callable } +{ setter callable } ; M: struct-type heap-size size>> ; From 0069547e908daf030ae1d493995b9fa4073f5993 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 3 Feb 2009 00:33:04 +0100 Subject: [PATCH 005/170] Fix suboptimal prime number factoring --- basis/math/primes/factors/factors-tests.factor | 1 + basis/math/primes/factors/factors.factor | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor index f247683c1c..983de51216 100644 --- a/basis/math/primes/factors/factors-tests.factor +++ b/basis/math/primes/factors/factors-tests.factor @@ -6,3 +6,4 @@ USING: math.primes.factors tools.test ; { { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test { 999967000236000612 } [ 999969000187000867 totient ] unit-test { 0 } [ 1 totient ] unit-test +{ { 425612003 } } [ 425612003 factors ] unit-test diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 05d6b26010..4c36fc0a85 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -16,7 +16,11 @@ IN: math.primes.factors PRIVATE> : group-factors ( n -- seq ) - [ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ; + [ + 2 + [ 2dup sq < ] [ write-factor next-prime ] [ ] until + drop dup 2 < [ drop ] [ 1 2array , ] if + ] { } make ; : unique-factors ( n -- seq ) group-factors [ first ] map ; From babe9bb2fdabd488fcd1293e50b2bb1d0095e3e6 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 01:25:48 -0600 Subject: [PATCH 006/170] Making xml.dispatch compile --- basis/xml-rpc/xml-rpc.factor | 8 +++- basis/xml/dispatch/dispatch-docs.factor | 18 ++++----- basis/xml/dispatch/dispatch-tests.factor | 4 +- basis/xml/dispatch/dispatch.factor | 38 ++++++++++--------- .../space-file-decoder.factor | 2 +- 5 files changed, 40 insertions(+), 30 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index d9028756f2..304f7400fa 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -113,14 +113,18 @@ M: server-error error. "Description: " write dup message>> print "Tag: " write tag>> xml>string print ; -PROCESS: xml>item ( tag -- object ) +TAGS: xml>item ( tag -- object ) TAG: string xml>item children>string ; -TAG: i4/int/double xml>item +: children>number ( tag -- n ) children>string string>number ; +TAG: i4 xml>item children>number ; +TAG: int xml>item children>number ; +TAG: double xml>item children>number ; + TAG: boolean xml>item dup children>string { { [ dup "1" = ] [ 2drop t ] } diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor index 572a75cd05..d3d24d736c 100644 --- a/basis/xml/dispatch/dispatch-docs.factor +++ b/basis/xml/dispatch/dispatch-docs.factor @@ -6,20 +6,20 @@ IN: xml.dispatch ABOUT: "xml.dispatch" ARTICLE: "xml.dispatch" "Dispatch on XML tag names" -"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" -{ $subsection POSTPONE: PROCESS: } +"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" +{ $subsection POSTPONE: TAGS: } "and to define a new 'method' for this word, use" { $subsection POSTPONE: TAG: } ; -HELP: PROCESS: -{ $syntax "PROCESS: word" } +HELP: TAGS: +{ $syntax "TAGS: word" } { $values { "word" "a new word to define" } } -{ $description "creates a new word to process XML tags" } +{ $description "Creates a new word to which dispatches on XML tag names." } { $see-also POSTPONE: TAG: } ; HELP: TAG: { $syntax "TAG: tag word definition... ;" } -{ $values { "tag" "an xml tag name" } { "word" "an XML process" } } -{ $description "defines what a process should do when it encounters a specific tag" } -{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } -{ $see-also POSTPONE: PROCESS: } ; +{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } +{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } +{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } +{ $see-also POSTPONE: TAGS: } ; diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor index 6f3179bc02..e76a759291 100644 --- a/basis/xml/dispatch/dispatch-tests.factor +++ b/basis/xml/dispatch/dispatch-tests.factor @@ -4,7 +4,7 @@ USING: xml io kernel math sequences strings xml.utilities tools.test math.parser xml.dispatch ; IN: xml.dispatch.tests -PROCESS: calculate ( tag -- n ) +TAGS: calculate ( tag -- n ) : calc-2children ( tag -- n n ) children-tags first2 [ calculate ] dip calculate ; @@ -29,3 +29,5 @@ TAG: neg calculate "13-8" calc-arith ] unit-test + +\ calc-arith must-infer diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor index 23cb43cc47..613836aae2 100644 --- a/basis/xml/dispatch/dispatch.factor +++ b/basis/xml/dispatch/dispatch.factor @@ -1,27 +1,31 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: words assocs kernel accessors parser sequences summary -lexer splitting fry ; +lexer splitting fry combinators ; IN: xml.dispatch -TUPLE: process-missing process tag ; -M: process-missing summary - drop "Tag not implemented on process" ; +TUPLE: no-tag name word ; +M: no-tag summary + drop "The tag-dispatching word has no method for the given tag name" ; -: run-process ( tag word -- ) - 2dup "xtable" word-prop - [ dup main>> ] dip at* [ 2nip call ] [ - drop \ process-missing boa throw - ] if ; +: compile-tags ( word xtable -- quot ) + >alist swap '[ _ no-tag boa throw ] [ ] like suffix + '[ dup main>> _ case ] ; -: PROCESS: +: define-tags ( word -- ) + dup dup "xtable" word-prop compile-tags define ; + +: define-tag ( string word quot -- ) + -rot [ "xtable" word-prop set-at ] [ define-tags ] bi ; + +:: define-tag ( string word quot -- ) + quot string word "xtable" word-prop set-at + word define-tags ; + +: TAGS: CREATE - dup H{ } clone "xtable" set-word-prop - dup '[ _ run-process ] define ; parsing + [ H{ } clone "xtable" set-word-prop ] + [ define-tags ] bi ; parsing : TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ; - parsing + scan scan-word parse-definition define-tag ; parsing diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor index 872ddbcee3..bd3915cb36 100755 --- a/extra/4DNav/space-file-decoder/space-file-decoder.factor +++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor @@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder : decode-number-array ( x -- y ) "," split [ string>number ] map ; -PROCESS: adsoda-read-model ( tag -- ) +TAGS: adsoda-read-model ( tag -- ) TAG: dimension adsoda-read-model children>> first string>number ; From 009ea7ad4562dc7ec36fa8516c3c9d16f2a42b7a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 12:32:47 -0600 Subject: [PATCH 007/170] Fixing bug in XML where prolog isn't considered; whenever you write XML, the encoding is listed as UTF-8. --- basis/xml/dispatch/dispatch.factor | 2 +- basis/xml/tests/test.factor | 1 + basis/xml/writer/writer-tests.factor | 9 ++++++++- basis/xml/writer/writer.factor | 2 +- basis/xml/xml.factor | 21 +++++++++++++++------ 5 files changed, 26 insertions(+), 9 deletions(-) diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor index 613836aae2..9c4a2448c6 100644 --- a/basis/xml/dispatch/dispatch.factor +++ b/basis/xml/dispatch/dispatch.factor @@ -9,7 +9,7 @@ M: no-tag summary drop "The tag-dispatching word has no method for the given tag name" ; : compile-tags ( word xtable -- quot ) - >alist swap '[ _ no-tag boa throw ] [ ] like suffix + >alist swap '[ _ no-tag boa throw ] suffix '[ dup main>> _ case ] ; : define-tags ( word -- ) diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 337c19bfe1..dcd428d9e6 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -67,3 +67,4 @@ SYMBOL: xml-file [ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test [ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test [ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test +[ "1.1" ] [ "" string>xml prolog>> version>> ] unit-test diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index d09ae08b3f..f414264e11 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer tools.test fry xml kernel multiline -xml.writer.private io.streams.string xml.utilities sequences ; +xml.writer.private io.streams.string xml.utilities sequences +io.encodings.utf8 io.files accessors io.directories ; IN: xml.writer.tests \ write-xml must-infer @@ -59,3 +60,9 @@ IN: xml.writer.tests [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test [ "" ] [ "" xml>string ] unit-test + +: test-file "resource:basis/xml/writer/test.xml" ; + +[ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test +[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test +[ ] [ test-file delete-file ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index a713790973..4b80e0818e 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -164,7 +164,7 @@ M: sequence write-xml M: prolog write-xml "> write-quoted ] - [ " encoding=" write encoding>> write-quoted ] + [ drop " encoding=\"UTF-8\"" write ] [ standalone>> [ " standalone=\"yes\"" write ] when ] tri "?>" write ; diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 5ca486a57f..57c1b6dbd3 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files io.streams.string kernel namespaces sequences strings io.encodings.utf8 xml.data xml.errors xml.elements ascii xml.entities xml.writer xml.state xml.autoencoding assocs xml.tokenize -combinators.short-circuit xml.name ; +combinators.short-circuit xml.name splitting ; IN: xml ; + dup [ tag? ] find [ + assure-tags cut + [ cut-prolog ] [ rest ] bi* + no-pre/post no-post-tags + ] dip swap ; ! * Views of XML From 292ebd4a4cd9f0374b1a109e518fd064d041082a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 12:34:18 -0600 Subject: [PATCH 008/170] Fixing xml.dispatch --- basis/xml/dispatch/dispatch.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor index 9c4a2448c6..f6b9e107e3 100644 --- a/basis/xml/dispatch/dispatch.factor +++ b/basis/xml/dispatch/dispatch.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: words assocs kernel accessors parser sequences summary -lexer splitting fry combinators ; +lexer splitting fry combinators locals ; IN: xml.dispatch TUPLE: no-tag name word ; @@ -15,9 +15,6 @@ M: no-tag summary : define-tags ( word -- ) dup dup "xtable" word-prop compile-tags define ; -: define-tag ( string word quot -- ) - -rot [ "xtable" word-prop set-at ] [ define-tags ] bi ; - :: define-tag ( string word quot -- ) quot string word "xtable" word-prop set-at word define-tags ; From c7a070ba8e08f2c39ecfc0de124195c978b277ad Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 13:25:51 -0600 Subject: [PATCH 009/170] Fixing typo in xml.dispatch --- basis/xml/dispatch/dispatch.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor index f6b9e107e3..af47f7c14c 100644 --- a/basis/xml/dispatch/dispatch.factor +++ b/basis/xml/dispatch/dispatch.factor @@ -8,10 +8,14 @@ TUPLE: no-tag name word ; M: no-tag summary drop "The tag-dispatching word has no method for the given tag name" ; +alist swap '[ _ no-tag boa throw ] suffix '[ dup main>> _ case ] ; +PRIVATE> + : define-tags ( word -- ) dup dup "xtable" word-prop compile-tags define ; From fa0d5de2e4c903baf3ab5ce26c19535e50127b3d Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 17:29:35 -0600 Subject: [PATCH 010/170] Speeding up xml.literals by 3x using code generation --- basis/xml/literals/literals-tests.factor | 2 +- basis/xml/literals/literals.factor | 113 +++++++++++++++-------- 2 files changed, 75 insertions(+), 40 deletions(-) diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor index 59bd178f39..ec68a034a6 100644 --- a/basis/xml/literals/literals-tests.factor +++ b/basis/xml/literals/literals-tests.factor @@ -55,7 +55,7 @@ IN: xml.literals.tests [ "" ] [ f [XML <-> XML] xml>string ] unit-test \ XML] ] must-infer [ [XML <-> /> XML] ] must-infer [ xml-chunk ] [ [ [XML XML] ] first class ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor index f245c7a542..1520afdde4 100644 --- a/basis/xml/literals/literals.factor +++ b/basis/xml/literals/literals.factor @@ -3,11 +3,34 @@ USING: xml xml.state kernel sequences fry assocs xml.data accessors strings make multiline parser namespaces macros sequences.deep generalizations words combinators -math present arrays unicode.categories ; +math present arrays unicode.categories locals.backend +quotations ; IN: xml.literals > ] dip each-attrs ] } + { [ over attrs? ] [ each-attrs ] } + { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] } + [ 2drop ] + } cond ; inline recursive + +: each-interpolated ( xml quot -- ) + '[ _ (each-interpolated) ] deep-each ; inline + +: has-interpolated? ( xml -- ? ) + ! If this becomes a performance problem, it can be improved + f swap [ 2drop t ] each-interpolated ; + +: when-interpolated ( xml quot -- genquot ) + [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline + : string>chunk ( string -- chunk ) t interpolating? [ string>xml-chunk ] with-variable ; @@ -16,17 +39,34 @@ IN: xml.literals DEFER: interpolate-sequence -: interpolate-attrs ( table attrs -- attrs ) - swap '[ - dup interpolated? - [ var>> _ at dup [ present ] when ] when - ] assoc-map [ nip ] assoc-filter ; +: get-interpolated ( interpolated -- quot ) + var>> '[ [ _ swap at ] keep ] ; -: interpolate-tag ( table tag -- tag ) - [ nip name>> ] - [ attrs>> interpolate-attrs ] - [ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri - ; +: ?present ( object -- string ) + dup [ present ] when ; + +: interpolate-attr ( key value -- quot ) + dup interpolated? + [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ] + [ 2array '[ _ swap ] ] if ; + +: filter-nulls ( assoc -- newassoc ) + [ nip ] assoc-filter ; + +: interpolate-attrs ( attrs -- quot ) + [ + [ [ interpolate-attr ] { } assoc>map [ ] join ] + [ assoc-size ] bi + '[ @ _ swap [ narray filter-nulls ] dip ] + ] when-interpolated ; + +: interpolate-tag ( tag -- quot ) + [ + [ name>> ] + [ attrs>> interpolate-attrs ] + [ children>> interpolate-sequence ] tri + '[ _ swap @ @ [ ] dip ] + ] when-interpolated ; GENERIC: push-item ( item -- ) M: string push-item , ; @@ -37,30 +77,33 @@ M: sequence push-item M: number push-item present , ; M: xml-chunk push-item % ; -GENERIC: interpolate-item ( table item -- ) -M: object interpolate-item nip , ; -M: tag interpolate-item interpolate-tag , ; -M: interpolated interpolate-item - var>> swap at push-item ; +: concat-interpolate ( array -- newarray ) + [ [ push-item ] each ] { } make ; -: interpolate-sequence ( table seq -- seq ) - [ [ interpolate-item ] with each ] { } make ; +GENERIC: interpolate-item ( item -- quot ) +M: object interpolate-item [ swap ] curry ; +M: tag interpolate-item interpolate-tag ; +M: interpolated interpolate-item get-interpolated ; -: interpolate-xml-doc ( table xml -- xml ) - (clone) [ interpolate-tag ] change-body ; +: interpolate-sequence ( seq -- quot ) + [ + [ [ interpolate-item ] map concat ] + [ length ] bi + '[ @ _ swap [ narray concat-interpolate ] dip ] + ] when-interpolated ; -: (each-interpolated) ( item quot: ( interpolated -- ) -- ) - { - { [ over interpolated? ] [ call ] } - { [ over tag? ] [ - [ attrs>> values [ interpolated? ] filter ] dip each - ] } - { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] } - [ 2drop ] - } cond ; inline recursive +GENERIC: [interpolate-xml] ( xml -- quot ) -: each-interpolated ( xml quot -- ) - '[ _ (each-interpolated) ] deep-each ; inline +M: xml [interpolate-xml] + dup body>> interpolate-tag + '[ _ (clone) swap @ drop >>body ] ; + +M: xml-chunk [interpolate-xml] + interpolate-sequence + '[ @ drop ] ; + +MACRO: interpolate-xml ( xml -- quot ) + [interpolate-xml] ; : number<-> ( doc -- dup ) 0 over [ @@ -69,14 +112,6 @@ M: interpolated interpolate-item ] unless drop ] each-interpolated drop ; -GENERIC: interpolate-xml ( table xml -- xml ) - -M: xml interpolate-xml - interpolate-xml-doc ; - -M: xml-chunk interpolate-xml - interpolate-sequence ; - : >search-hash ( seq -- hash ) [ dup search ] H{ } map>assoc ; From 023a44118ae649c9496bd792c80de83b5025b2fd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 4 Feb 2009 17:31:25 -0600 Subject: [PATCH 011/170] inverse bug fix --- extra/inverse/inverse-tests.factor | 3 +++ extra/inverse/inverse.factor | 5 +++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index a9234fcff4..9d81992eae 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -71,6 +71,9 @@ C: nil [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test [ ] [ 3 [ _ ] undo ] unit-test +[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test +[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test + [ { 1 } ] [ { 1 2 3 } [ { 2 3 } append ] undo ] unit-test [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index a86e673c9c..1006e45e77 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations continuations debugger classes.tuple namespaces make vectors bit-arrays byte-arrays strings sbufs math.functions macros sequences.private combinators mirrors splitting -combinators.short-circuit fry words.symbol ; +combinators.short-circuit fry words.symbol generalizations ; RENAME: _ fry => __ IN: inverse @@ -163,7 +163,7 @@ ERROR: missing-literal ; \ - [ + ] [ - ] define-math-inverse \ * [ / ] [ / ] define-math-inverse \ / [ * ] [ / ] define-math-inverse -\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse +\ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse \ ? 2 [ [ assert-literal ] bi@ @@ -199,6 +199,7 @@ DEFER: _ \ 2array [ 2 assure-length first2 ] define-inverse \ 3array [ 3 assure-length first3 ] define-inverse \ 4array [ 4 assure-length first4 ] define-inverse +\ narray 1 [ [ firstn ] curry ] define-pop-inverse \ first [ 1array ] define-inverse \ first2 [ 2array ] define-inverse From 9fd675a632db492958366bc85e4e99e1646691c5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:28:57 +0100 Subject: [PATCH 012/170] FUEL: Accept '?' in prompts for word and vocabs. --- misc/fuel/fuel-completion.el | 33 ++++++++++++++++++++++++++------- misc/fuel/fuel-edit.el | 9 +-------- misc/fuel/fuel-help.el | 2 +- misc/fuel/fuel-markup.el | 3 ++- misc/fuel/fuel-scaffold.el | 2 +- misc/fuel/fuel-xref.el | 2 +- 6 files changed, 32 insertions(+), 19 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index e6ec8b2dc9..165a9d9b66 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -18,6 +18,15 @@ (require 'fuel-eval) (require 'fuel-log) + +;;; Aux: + +(defvar fuel-completion--minibuffer-map + (let ((map (make-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map "?" 'self-insert-command) + map)) + ;;; Vocabs dictionary: @@ -33,7 +42,8 @@ fuel-completion--vocabs) (defun fuel-completion--read-vocab (&optional reload init-input history) - (let ((vocabs (fuel-completion--vocabs reload))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs reload))) (completing-read "Vocab name: " vocabs nil nil init-input history))) (defsubst fuel-completion--vocab-list (prefix) @@ -170,12 +180,21 @@ terminates a current completion." (cons completions partial))) (defun fuel-completion--read-word (prompt &optional default history all) - (completing-read prompt - (if all fuel-completion--all-words-list-func - fuel-completion--word-list-func) - nil nil nil - history - (or default (fuel-syntax-symbol-at-point)))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)) + (completing-read prompt + (if all fuel-completion--all-words-list-func + fuel-completion--word-list-func) + nil nil nil + history + (or default (fuel-syntax-symbol-at-point))))) + +(defun fuel-completion--read-vocab (refresh) + (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) + (if vocabs + (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) + (read-string prompt nil fuel-edit--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index e5f0ffd26f..5860fb998a 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -57,13 +57,6 @@ (fuel-edit--visit-file (car loc) fuel-edit-word-method) (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) -(defun fuel-edit--read-vocabulary-name (refresh) - (let* ((vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) - (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) - (defun fuel-edit--edit-article (name) (let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) @@ -80,7 +73,7 @@ When called interactively, asks for vocabulary with completion. With prefix argument, refreshes cached vocabulary list." (interactive "P") - (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh))) + (let* ((vocab (or vocab (fuel-completion--read-vocab refresh))) (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index a82de388da..cfc8cab7f1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -257,7 +257,7 @@ buffer." (defun fuel-help-vocab (vocab) "Ask for a vocabulary name and show its help page." - (interactive (list (fuel-edit--read-vocabulary-name nil))) + (interactive (list (fuel-completion--read-vocab nil))) (fuel-help--get-vocab vocab)) (defun fuel-help-next (&optional forget-current) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 4844233ae7..980ea111a6 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -282,7 +282,8 @@ (fuel-markup--insert-newline) (dolist (s (cdr e)) (fuel-markup--snippet (list '$snippet s)) - (newline))) + (newline)) + (newline)) (defun fuel-markup--markup-example (e) (fuel-markup--insert-newline) diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index 05d825593c..ac400c5622 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -71,7 +71,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to `user-full-name') for the name to be inserted in the generated file." (interactive "P") (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name nil))) + (fuel-completion--read-vocab nil))) (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) "fuel")) (ret (fuel-eval--send/wait cmd)) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 4d444ebe3e..faf1897304 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -244,7 +244,7 @@ With prefix argument, force reload of vocabulary list." With prefix argument, ask for the vocab." (interactive "P") (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name)))) + (fuel-completion--read-vocab nil)))) (when vocab (fuel-xref--show-vocab-words vocab (fuel-syntax--file-has-private))))) From 84846e21d840c7d6cc74db4d6e04c1062c640baf Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:45:44 +0100 Subject: [PATCH 013/170] FUEL: Small nits. --- misc/fuel/fuel-completion.el | 12 +++++++----- misc/fuel/fuel-edit.el | 1 - 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index 165a9d9b66..c21d25901f 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -188,13 +188,15 @@ terminates a current completion." history (or default (fuel-syntax-symbol-at-point))))) +(defvar fuel-completion--vocab-history nil) + (defun fuel-completion--read-vocab (refresh) - (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) - (vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) + (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history) + (read-string prompt nil fuel-completion--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index 5860fb998a..941f57140e 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -65,7 +65,6 @@ ;;; Editing commands: (defvar fuel-edit--word-history nil) -(defvar fuel-edit--vocab-history nil) (defvar fuel-edit--previous-location nil) (defun fuel-edit-vocabulary (&optional refresh vocab) From f101ca606da2be44da1c863a88227d34b9839f0a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Feb 2009 09:09:24 -0600 Subject: [PATCH 014/170] use bi --- basis/roman/roman.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 81a6d69a09..24713545b1 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -31,7 +31,7 @@ ERROR: roman-range-error n ; ] 2each drop ; : (roman>) ( seq -- n ) - dup [ roman>n ] map swap all-eq? [ + [ [ roman>n ] map ] [ all-eq? ] bi [ sum ] [ first2 swap - From b9839b0c320d5962ac2568b437c3adbd5fe00ae6 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 14:21:36 -0600 Subject: [PATCH 015/170] XML literals work with inverse now --- {extra => basis}/inverse/authors.txt | 0 {extra => basis}/inverse/inverse-docs.factor | 0 {extra => basis}/inverse/inverse-tests.factor | 0 {extra => basis}/inverse/inverse.factor | 0 {extra => basis}/inverse/summary.txt | 0 {extra => basis}/inverse/tags.txt | 0 basis/xml/literals/literals-tests.factor | 34 +++++++++ basis/xml/literals/literals.factor | 70 +++++++++++++++++++ 8 files changed, 104 insertions(+) rename {extra => basis}/inverse/authors.txt (100%) rename {extra => basis}/inverse/inverse-docs.factor (100%) rename {extra => basis}/inverse/inverse-tests.factor (100%) rename {extra => basis}/inverse/inverse.factor (100%) rename {extra => basis}/inverse/summary.txt (100%) rename {extra => basis}/inverse/tags.txt (100%) diff --git a/extra/inverse/authors.txt b/basis/inverse/authors.txt similarity index 100% rename from extra/inverse/authors.txt rename to basis/inverse/authors.txt diff --git a/extra/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor similarity index 100% rename from extra/inverse/inverse-docs.factor rename to basis/inverse/inverse-docs.factor diff --git a/extra/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor similarity index 100% rename from extra/inverse/inverse-tests.factor rename to basis/inverse/inverse-tests.factor diff --git a/extra/inverse/inverse.factor b/basis/inverse/inverse.factor similarity index 100% rename from extra/inverse/inverse.factor rename to basis/inverse/inverse.factor diff --git a/extra/inverse/summary.txt b/basis/inverse/summary.txt similarity index 100% rename from extra/inverse/summary.txt rename to basis/inverse/summary.txt diff --git a/extra/inverse/tags.txt b/basis/inverse/tags.txt similarity index 100% rename from extra/inverse/tags.txt rename to basis/inverse/tags.txt diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor index ec68a034a6..0d8367c144 100644 --- a/basis/xml/literals/literals-tests.factor +++ b/basis/xml/literals/literals-tests.factor @@ -66,3 +66,37 @@ IN: xml.literals.tests [ 1 ] [ [ XML> ] length ] unit-test [ "" ] [ [XML XML] concat ] unit-test + +USE: inverse + +[ "foo" ] [ [XML foo XML] [ [XML <-> XML] ] undo ] unit-test +[ "foo" ] [ [XML XML] [ [XML /> XML] ] undo ] unit-test +[ "foo" "baz" ] [ [XML baz XML] [ [XML ><-> XML] ] undo ] unit-test + +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "byes" ] } + { [ [XML /> XML] ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ [XML pple XML] dispatch ] unit-test +[ "banana" ] [ [XML anana XML] dispatch ] unit-test +[ "byes" ] [ [XML XML] dispatch ] unit-test +[ "bnowhere" ] [ [XML XML] dispatch ] unit-test +[ "baboon" ] [ [XML aboon XML] dispatch ] unit-test +[ "apple" ] [ pple XML> dispatch ] unit-test +[ "apple" ] [ pple XML> body>> dispatch ] unit-test + +: dispatch-doc ( xml -- string ) + { + { [ <-> XML> ] [ "a" prepend ] } + { [ <-> XML> ] [ "b" prepend ] } + { [ XML> ] [ "byes" ] } + { [ /> XML> ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ pple XML> dispatch-doc ] unit-test +[ "apple" ] [ [XML pple XML] dispatch-doc ] unit-test +[ "apple" ] [ pple XML> body>> dispatch-doc ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor index 1520afdde4..4648f7b0e7 100644 --- a/basis/xml/literals/literals.factor +++ b/basis/xml/literals/literals.factor @@ -142,3 +142,73 @@ PRIVATE> : [XML "XML]" [ string>chunk ] parse-def ; parsing + +USING: inverse sorting fry combinators.short-circuit ; + +: remove-blanks ( seq -- newseq ) + [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; + +GENERIC: >xml ( xml -- tag ) +M: xml >xml body>> ; +M: tag >xml ; +M: xml-chunk >xml + remove-blanks + [ length 1 =/fail ] + [ first dup tag? [ fail ] unless ] bi ; +M: object >xml fail ; + +: 1chunk ( object -- xml-chunk ) + 1array ; + +GENERIC: >xml-chunk ( xml -- chunk ) +M: xml >xml-chunk body>> 1chunk ; +M: xml-chunk >xml-chunk ; +M: object >xml-chunk 1chunk ; + +GENERIC: [undo-xml] ( xml -- quot ) + +M: xml [undo-xml] + body>> [undo-xml] '[ >xml @ ] ; + +M: xml-chunk [undo-xml] + seq>> [undo-xml] '[ >xml-chunk @ ] ; + +: undo-attrs ( attrs -- quot: ( attrs -- ) ) + [ + [ main>> ] dip dup interpolated? + [ var>> '[ _ attr _ set ] ] + [ '[ _ attr _ =/fail ] ] if + ] { } assoc>map '[ _ cleave ] ; + +M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) + { + [ name>> main>> '[ name>> main>> _ =/fail ] ] + [ attrs>> undo-attrs ] + [ children>> [undo-xml] '[ children>> @ ] ] + } cleave '[ _ _ _ tri ] ; + +: firstn-strong ( seq n -- ... ) + [ swap length =/fail ] + [ firstn ] 2bi ; inline + +M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) ) + remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi + '[ remove-blanks _ firstn-strong _ spread ] ; + +M: string [undo-xml] ( string -- quot: ( string -- ) ) + '[ _ =/fail ] ; + +M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) ) + '[ _ =/fail ] ; + +M: interpolated [undo-xml] + var>> '[ _ set ] ; + +: >enum ( assoc -- enum ) + ! Assumes keys are 0..n + >alist sort-keys values ; + +: undo-xml ( xml -- quot ) + [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; + +\ interpolate-xml 1 [ undo-xml ] define-pop-inverse From cc89943c085d02f7a590a64908627beffd2dc35e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 14:34:55 -0600 Subject: [PATCH 016/170] Getting rid of html.elements from most vocabs --- basis/furnace/chloe-tags/chloe-tags.factor | 26 +++++++++++++------ basis/furnace/furnace-tests.factor | 2 +- basis/furnace/sessions/sessions.factor | 2 +- basis/furnace/utilities/utilities.factor | 9 +++---- basis/html/templates/chloe/chloe-docs.factor | 6 ++--- basis/html/templates/chloe/chloe-tests.factor | 2 +- basis/html/templates/chloe/chloe.factor | 12 ++++----- .../templates/chloe/compiler/compiler.factor | 3 +++ basis/html/templates/templates.factor | 23 +++++++++++----- extra/webapps/user-admin/user-admin.factor | 1 - 10 files changed, 52 insertions(+), 34 deletions(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index dd24d8dcde..be24eb5224 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -66,16 +66,26 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; tri [ =href a> ] [code] ; -: a-end-tag ( tag -- ) - drop [ ] [code] ; +: process-attrs ( assoc -- newassoc ) + [ "@" ?head [ value present ] when ] assoc-map ; + +: non-chloe-attrs ( tag -- ) + attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ; + +: a-attrs ( tag -- ) + [ non-chloe-attrs ] + [ compile-link-attrs ] + [ compile-a-url ] tri + [ swap "href" swap set-at ] [code] ; CHLOE: a - [ - [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri - ] compile-with-scope ; + [ a-attrs ] + [ compile-children>string ] bi + [ [XML <-> XML] swap >>attrs ] + [xml-code] ; CHLOE: base - compile-a-url [ ] [code] ; + compile-a-url [ [XML /> XML] ] [xml-code] ; : compile-hidden-form-fields ( for -- ) '[ @@ -121,13 +131,13 @@ CHLOE: form
- XML> ; + XML> body>> clone ; : add-tag-attrs ( attrs tag -- ) attrs>> swap update ; CHLOE: button - button-tag-markup body>> + button-tag-markup { [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ] diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f6e5434997..f01260c68b 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -30,7 +30,7 @@ M: base-path-check-responder call-responder* "a/b/c" split-path main-responder get call-responder body>> ] unit-test -[ "" ] +[ "" ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ] unit-test diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 8b7e1ab83f..52e705c153 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences continuations fry calendar combinators combinators.short-circuit destructors alarms io.sockets db db.tuples db.types http http.server http.server.dispatchers http.server.filters -html.elements furnace.cache furnace.scopes furnace.utilities ; +furnace.cache furnace.scopes furnace.utilities ; IN: furnace.sessions TUPLE: session < scope user-agent client ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index e09047b74a..4a9f71e8a9 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make assocs sequences kernel classes splitting words vocabs.loader accessors strings combinators arrays -continuations present fry urls html.elements http http.server +continuations present fry urls http http.server xml.literals xml.writer http.server.redirection http.server.remapping ; IN: furnace.utilities @@ -83,11 +83,8 @@ M: object modify-form drop ; : hidden-form-field ( value name -- ) over [ - + [XML name=<->/> XML] + write-xml ] [ 2drop ] if ; : nested-forms-key "__n" ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index f6408d3b59..b2259e629e 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags" "" " View" - "s" + "" } } } { { $snippet "t:base" } { "Outputs an HTML " { $snippet "" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } } @@ -261,8 +261,8 @@ $nl ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:" { $code "SINGLETON: image" } -"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":" -{ $code "M: image render* 2drop ;" } +"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":" +{ $code "M: image render* 2drop [XML /> XML] ;" } "Finally, we can define a Chloe component:" { $code "COMPONENT: image" } "We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":" diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 19b67f7018..184f57051a 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -135,7 +135,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index e5b40fcfaa..99afbc31bd 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -8,7 +8,6 @@ logging continuations xml.data xml.writer xml.literals strings html.forms html -html.elements html.components html.templates html.templates.chloe.compiler @@ -28,7 +27,9 @@ CHLOE: write-title drop "head" tag-stack get member? "title" tag-stack get member? not and - [ write-title ] [ write-title ] ? [code] ; + [ get-title [XML <-> XML] ] + [ get-title ] ? + [xml-code] ; CHLOE: style dup "include" optional-attr [ @@ -39,10 +40,9 @@ CHLOE: style CHLOE: write-style drop [ - - ] [code] ; + get-style + [XML XML] + ] [xml-code] ; CHLOE: even [ "index" value even? swap when ] process-children ; diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 7180e8cdbc..394b5ef359 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -42,6 +42,9 @@ DEFER: compile-element : [code-with] ( obj quot -- ) reset-buffer [ , ] [ % ] bi* ; +: [xml-code] ( quot -- ) + [ write-xml ] compose [code] ; + : expand-attr ( value -- ) [ value present write ] [code-with] ; diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index efaf8d6a62..c0fec8d1b6 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html io.streams.string +arrays strings html io.streams.string assocs quotations xml.data xml.writer xml.literals ; IN: html.templates @@ -34,8 +34,11 @@ SYMBOL: title : set-title ( string -- ) title get >box ; +: get-title ( -- string ) + title get value>> ; + : write-title ( -- ) - title get value>> write ; + get-title write ; SYMBOL: style @@ -43,24 +46,30 @@ SYMBOL: style "\n" style get push-all style get push-all ; +: get-style ( -- string ) + style get >string ; + : write-style ( -- ) - style get >string write ; + get-style write ; SYMBOL: atom-feeds : add-atom-feed ( title url -- ) 2array atom-feeds get push ; -: write-atom-feeds ( -- ) +: get-atom-feeds ( -- xml ) atom-feeds get [ - first2 [XML + [XML href=<->/> - XML] write-xml - ] each ; + XML] + ] { } assoc>map ; + +: write-atom-feeds ( -- ) + get-atom-feeds write-xml ; SYMBOL: nested-template? diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 9d4e348596..c0cd601af5 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -3,7 +3,6 @@ USING: kernel sequences accessors namespaces combinators words assocs db.tuples arrays splitting strings validators urls html.forms -html.elements html.components furnace furnace.boilerplate From 8411983f20813316ec11a8bc32ccf2f57c4f12bd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Feb 2009 14:40:41 -0600 Subject: [PATCH 017/170] fix build-support --- build-support/factor.sh | 3 --- 1 file changed, 3 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 36d52601a5..3517d8f4ba 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -295,9 +295,6 @@ set_build_info() { elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_TARGET=winnt-x86-64 - elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then - MAKE_IMAGE_TARGET=winnt-x86.32 - MAKE_TARGET=winnt-x86-32 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 MAKE_TARGET=$OS-x86-64 From c24bc639d11f792f4eadd14e8fbe7e6da4584574 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:29:59 -0600 Subject: [PATCH 018/170] unit tests for alien.fortran --- basis/alien/fortran/fortran-tests.factor | 141 +++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 basis/alien/fortran/fortran-tests.factor diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor new file mode 100644 index 0000000000..29bd024930 --- /dev/null +++ b/basis/alien/fortran/fortran-tests.factor @@ -0,0 +1,141 @@ +USING: alien.fortran alien.syntax tools.test ; +IN: alien.fortran.tests + +C-STRUCT: fortran_test_struct + { "int" "foo" } + { "float" "bar" } + { "char[4]" "bas" } ; + +! F-RECORD: fortran_test_record +! { "integer" "foo" } +! { "real" "bar" } +! { "character*4" "bar" } + +! fortran-name>symbol-name + +[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test +[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + +! fortran-type>c-type + +[ "short" ] +[ "integer*2" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer*4" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer" fortran-type>c-type ] unit-test + +[ "longlong" ] +[ "iNteger*8" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(*)" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(3,*)" fortran-type>c-type ] unit-test + +[ "int[3]" ] +[ "integer(3)" fortran-type>c-type ] unit-test + +[ "int[6]" ] +[ "integer(3,2)" fortran-type>c-type ] unit-test + +[ "int[24]" ] +[ "integer(4,3,2)" fortran-type>c-type ] unit-test + +[ "char[1]" ] +[ "character" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character*17" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character(17)" fortran-type>c-type ] unit-test + +[ "int" ] +[ "logical" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real" fortran-type>c-type ] unit-test + +[ "double" ] +[ "double precision" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real*4" fortran-type>c-type ] unit-test + +[ "double" ] +[ "real*8" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "double complex" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex*8" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "fortran_test_struct" ] +[ "fortran_test_struct" fortran-type>c-type ] unit-test + +[ "fortran_test_record" ] +[ "fortran_test_record" fortran-type>c-type ] unit-test + +! fortran-arg-type>c-type + +[ "int*" { } ] +[ "integer" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(3)" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(*)" fortran-arg-type>c-type ] unit-test + +[ "fortran_test_struct*" { } ] +[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character(17)" fortran-arg-type>c-type ] unit-test + +! fortran-ret-type>c-type + +[ "void" { "char*" "long" } ] +[ "character(17)" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "integer" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "logical" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "real" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "double precision" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-complex)*" } ] +[ "complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-double-complex)*" } ] +[ "double complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "int*" } ] +[ "integer(*)" fortran-ret-type>c-type ] unit-test + +[ "void" { "fortran_test_record*" } ] +[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + From 4f1dc5cd0c46693d31ab51f7deaf6b2af41f8089 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:31:58 -0600 Subject: [PATCH 019/170] implement fortran-name>symbol-name and fortran-type>c-type --- basis/alien/fortran/fortran.factor | 140 +++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 basis/alien/fortran/fortran.factor diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor new file mode 100644 index 0000000000..d83df9bd45 --- /dev/null +++ b/basis/alien/fortran/fortran.factor @@ -0,0 +1,140 @@ +USING: accessors alien alien.c-types alien.syntax arrays ascii +assocs combinators fry kernel macros math.parser sequences splitting ; +IN: alien.fortran + +! XXX this currently only supports the gfortran/f2c abi. +! XXX we should also support ifort at some point for commercial BLASes + +C-STRUCT: (fortran-complex) + { "float" "r" } + { "float" "i" } ; +C-STRUCT: (fortran-double-complex) + { "double" "r" } + { "double" "i" } ; + +: fortran-c-abi ( -- abi ) "cdecl" ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +ERROR: invalid-fortran-type type ; + +c-types H{ + { "character" character-type } + { "integer" integer-type } + { "logical" logical-type } + { "real" real-type } + { "double precision" double-precision-type } + { "complex" real-complex-type } + { "double complex" double-complex-type } +} + +: append-dimensions ( base-c-type type -- c-type ) + dims>> + [ product number>string "[" "]" surround append ] when* ; + +MACRO: size-case-type ( cases -- ) + [ invalid-fortran-type ] suffix + '[ [ size>> _ case ] [ append-dimensions ] bi ] ; + +: simple-type ( type base-c-type -- c-type ) + swap + [ dup size>> [ invalid-fortran-type ] [ drop ] if ] + [ append-dimensions ] bi ; + +: new-fortran-type ( dims size class -- type ) + new [ (>>size) ] [ (>>dims) ] [ ] tri ; + +GENERIC: (fortran-type>c-type) ( type -- c-type ) + +M: integer-type (fortran-type>c-type) + { + { f [ "int" ] } + { 2 [ "short" ] } + { 4 [ "int" ] } + { 8 [ "longlong" ] } + } size-case-type ; +M: real-type (fortran-type>c-type) + { + { f [ "float" ] } + { 4 [ "float" ] } + { 8 [ "double" ] } + } size-case-type ; +M: complex-type (fortran-type>c-type) + { + { f [ "(fortran-complex)" ] } + { 8 [ "(fortran-complex)" ] } + { 16 [ "(fortran-double-complex)" ] } + } size-case-type ; + +M: double-precision-type (fortran-type>c-type) + "double" simple-type ; +M: double-complex-type (fortran-type>c-type) + "(fortran-double-complex)" simple-type ; +M: misc-type (fortran-type>c-type) + dup name>> simple-type ; + +: fix-character-type ( character-type -- character-type' ) + clone dup size>> + [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] + [ dup dims>> [ ] [ { 1 } >>dims ] if ] if ; + +M: character-type (fortran-type>c-type) + fix-character-type "char" simple-type ; + +: dimension>number ( string -- number ) + dup "*" = [ drop 0 ] [ string>number ] if ; + +: parse-dims ( string -- string' dim ) + "(" split1 dup + [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; + +: parse-size ( string -- string' size ) + "*" split1 dup [ string>number ] when ; + +: parse-fortran-type ( fortran-type-string -- type ) + parse-dims swap parse-size swap + dup >lower fortran>c-types at* + [ nip new-fortran-type ] [ drop misc-type boa ] if ; + +: c-type>pointer ( c-type -- c-type* ) + "[" split1 drop "*" append ; + +GENERIC: added-c-args ( type -- args ) + +M: fortran-type added-c-args drop { } ; +M: character-type added-c-args drop { "long" } ; + +PRIVATE> + +: fortran-type>c-type ( fortran-type -- c-type ) + parse-fortran-type (fortran-type>c-type) ; + +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; + +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; + +! : F-RECORD: ... ; parsing +! : F-ABI: ... ; parsing +! : F-SUBROUTINE: ... ; parsing +! : F-FUNCTION: ... ; parsing + From 4429c17f63840647ce2467dbb385126fd9a081ef Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 16:39:23 -0600 Subject: [PATCH 020/170] implement fortran-arg-type>c-type and fortran-ret-type>c-type --- basis/alien/fortran/fortran.factor | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index d83df9bd45..0c30258895 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -123,13 +123,38 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; +GENERIC: added-c-arg-values ( type -- arg-values ) + +M: fortran-type added-c-arg-values drop { } ; +M: character-type added-c-arg-values + fix-character-type dims>> first 1array ; + +GENERIC: returns-by-value? ( type -- ? ) + +M: fortran-type returns-by-value? drop f ; +M: number-type returns-by-value? dims>> not ; +M: complex-type returns-by-value? drop f ; + +GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) + +M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; +M: real-type (fortran-ret-type>c-type) drop "double" ; + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) parse-fortran-type (fortran-type>c-type) ; -: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; -: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type + [ (fortran-type>c-type) c-type>pointer ] + [ added-c-args ] bi ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type dup returns-by-value? + [ (fortran-ret-type>c-type) { } ] [ + "void" swap + [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + ] if ; : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; From 7b1f16ae5ed2ee0b788456db20a84eb7922f14d2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 18:51:50 -0600 Subject: [PATCH 021/170] fortran records --- basis/alien/fortran/fortran-tests.factor | 62 ++++++++++++++++++------ basis/alien/fortran/fortran.factor | 28 +++++++++-- basis/alien/structs/structs.factor | 7 ++- 3 files changed, 75 insertions(+), 22 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 29bd024930..11f0a2efc7 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,15 +1,11 @@ -USING: alien.fortran alien.syntax tools.test ; +USING: accessors alien alien.c-types alien.fortran alien.structs +alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests -C-STRUCT: fortran_test_struct - { "int" "foo" } - { "float" "bar" } - { "char[4]" "bas" } ; - -! F-RECORD: fortran_test_record -! { "integer" "foo" } -! { "real" "bar" } -! { "character*4" "bar" } +F-RECORD: fortran_test_record + { "integer" "foo" } + { "real" "bar" } + { "character*4" "bas" } ; ! fortran-name>symbol-name @@ -25,7 +21,7 @@ C-STRUCT: fortran_test_struct [ "integer*4" fortran-type>c-type ] unit-test [ "int" ] -[ "integer" fortran-type>c-type ] unit-test +[ "INTEGER" fortran-type>c-type ] unit-test [ "longlong" ] [ "iNteger*8" fortran-type>c-type ] unit-test @@ -84,9 +80,6 @@ C-STRUCT: fortran_test_struct [ "(fortran-double-complex)" ] [ "complex*16" fortran-type>c-type ] unit-test -[ "fortran_test_struct" ] -[ "fortran_test_struct" fortran-type>c-type ] unit-test - [ "fortran_test_record" ] [ "fortran_test_record" fortran-type>c-type ] unit-test @@ -101,8 +94,8 @@ C-STRUCT: fortran_test_struct [ "int*" { } ] [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "fortran_test_struct*" { } ] -[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test +[ "fortran_test_record*" { } ] +[ "fortran_test_record" fortran-arg-type>c-type ] unit-test [ "char*" { "long" } ] [ "character" fortran-arg-type>c-type ] unit-test @@ -139,3 +132,40 @@ C-STRUCT: fortran_test_struct [ "void" { "fortran_test_record*" } ] [ "fortran_test_record" fortran-ret-type>c-type ] unit-test +! fortran-sig>c-sig + +[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] +unit-test + +[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] +[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +! fortran-record>c-struct + +[ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } +} ] [ + { + { "DOUBLE PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct +] unit-test + +! F-RECORD: + +[ 12 ] [ "fortran_test_record" heap-size ] unit-test +[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test +[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test +[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 0c30258895..327db12909 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,5 +1,6 @@ -USING: accessors alien alien.c-types alien.syntax arrays ascii -assocs combinators fry kernel macros math.parser sequences splitting ; +USING: accessors alien alien.c-types alien.structs alien.syntax +arrays ascii assocs combinators fry kernel lexer macros math.parser +namespaces parser sequences splitting vectors vocabs.parser ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -65,9 +66,12 @@ MACRO: size-case-type ( cases -- ) GENERIC: (fortran-type>c-type) ( type -- c-type ) +M: f (fortran-type>c-type) ; + M: integer-type (fortran-type>c-type) { { f [ "int" ] } + { 1 [ "char" ] } { 2 [ "short" ] } { 4 [ "int" ] } { 8 [ "longlong" ] } @@ -140,6 +144,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; +: suffix! ( seq elt -- seq ) over push ; inline +: append! ( seq-a seq-b -- seq-a ) over push-all ; inline + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -156,10 +163,21 @@ PRIVATE> [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix ] if ; -: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; +: fortran-arg-types>c-types ( fortran-types -- c-types ) + [ length 1 ] keep + [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each + append >array ; -! : F-RECORD: ... ; parsing -! : F-ABI: ... ; parsing +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) + [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; + +: fortran-record>c-struct ( record -- struct ) + [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; + +: define-record ( name vocab fields -- ) + [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; + +: F-RECORD: scan in get parse-definition define-record ; parsing ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..cb3f90d358 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generic hashtables kernel kernel.private +USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs @@ -61,3 +61,8 @@ M: struct-type stack-size [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; + +: offset-of ( field struct -- offset ) + c-types get at fields>> + [ name>> = ] with find nip offset>> ; + From 2466cafbd1f23cbb2c7acd8ef5bb2f4dca980c93 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 19:04:21 -0600 Subject: [PATCH 022/170] Fixing stack effects of things that use TAGS: --- basis/xml-rpc/xml-rpc.factor | 2 +- .../space-file-decoder/space-file-decoder.factor | 12 +++++------- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 304f7400fa..24dfabc8ff 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -178,5 +178,5 @@ TAG: array xml>item ! This needs to do something in the event of an error [ send-rpc ] dip http-post nip string>xml receive-rpc ; -: invoke-method ( params method url -- ) +: invoke-method ( params method url -- response ) [ swap ] dip post-rpc ; diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor index bd3915cb36..ecc8f778fa 100755 --- a/extra/4DNav/space-file-decoder/space-file-decoder.factor +++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor @@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder : decode-number-array ( x -- y ) "," split [ string>number ] map ; -TAGS: adsoda-read-model ( tag -- ) +TAGS: adsoda-read-model ( tag -- model ) TAG: dimension adsoda-read-model children>> first string>number ; @@ -56,11 +56,9 @@ TAG: space adsoda-read-model ; : read-model-file ( path -- x ) - dup - [ - [ file>xml "space" tags-named first adsoda-read-model ] - [ drop ] recover - ] [ drop ] if - + [ + [ file>xml "space" tag-named adsoda-read-model ] + [ 2drop ] recover + ] [ ] if* ; From 0dd811557b160666b352f6bf2b5264cae1586919 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 20:28:36 -0600 Subject: [PATCH 023/170] Removing sequences.next --- basis/sequences/next/authors.txt | 1 - basis/sequences/next/next-tests.factor | 5 ----- basis/sequences/next/next.factor | 21 --------------------- basis/sequences/next/summary.txt | 1 - basis/sequences/next/tags.txt | 1 - basis/unicode/case/case.factor | 2 +- 6 files changed, 1 insertion(+), 30 deletions(-) delete mode 100644 basis/sequences/next/authors.txt delete mode 100644 basis/sequences/next/next-tests.factor delete mode 100644 basis/sequences/next/next.factor delete mode 100644 basis/sequences/next/summary.txt delete mode 100644 basis/sequences/next/tags.txt diff --git a/basis/sequences/next/authors.txt b/basis/sequences/next/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/basis/sequences/next/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/basis/sequences/next/next-tests.factor b/basis/sequences/next/next-tests.factor deleted file mode 100644 index be728b2d8e..0000000000 --- a/basis/sequences/next/next-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: sequences.next tools.test arrays kernel math sequences ; - -[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test - -[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test diff --git a/basis/sequences/next/next.factor b/basis/sequences/next/next.factor deleted file mode 100644 index 19b406cc58..0000000000 --- a/basis/sequences/next/next.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: kernel sequences sequences.private math ; -IN: sequences.next - - - -: each-next ( seq quot: ( next-elt elt -- ) -- ) - iterate-seq [ (map-next) ] 2curry each-integer ; inline - -: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq ) - over dup length swap new-sequence [ - iterate-seq [ (map-next) ] 2curry - ] dip [ collect ] keep ; inline diff --git a/basis/sequences/next/summary.txt b/basis/sequences/next/summary.txt deleted file mode 100644 index fe5bd315de..0000000000 --- a/basis/sequences/next/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Iteration with access to next element diff --git a/basis/sequences/next/tags.txt b/basis/sequences/next/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/basis/sequences/next/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 7566138e11..65fab0ac38 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data sequences sequences.next namespaces +USING: unicode.data sequences namespaces sbufs make unicode.syntax unicode.normalize math hints unicode.categories combinators unicode.syntax assocs strings splitting kernel accessors unicode.breaks fry locals ; From 86c3481f12ddd58a162c1d5994bd914a7e500443 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 21:17:03 -0600 Subject: [PATCH 024/170] Moving XML vocabularies around --- basis/farkup/farkup-tests.factor | 2 +- basis/farkup/farkup.factor | 2 +- basis/furnace/chloe-tags/chloe-tags.factor | 4 +- basis/help/html/html.factor | 2 +- basis/html/components/components-docs.factor | 2 +- basis/html/components/components.factor | 2 +- basis/html/elements/elements.factor | 2 +- basis/html/forms/forms.factor | 2 +- basis/html/html.factor | 4 +- basis/html/streams/streams.factor | 2 +- basis/html/templates/chloe/chloe.factor | 2 +- .../html/templates/chloe/syntax/syntax.factor | 2 +- basis/html/templates/templates.factor | 2 +- basis/http/http-tests.factor | 2 +- basis/http/server/responses/responses.factor | 2 +- basis/http/server/static/static.factor | 2 +- basis/lcs/diff2html/diff2html.factor | 2 +- basis/syndication/syndication.factor | 4 +- basis/xml-rpc/xml-rpc.factor | 4 +- basis/xml/data/data-docs.factor | 2 +- basis/xml/dispatch/dispatch-docs.factor | 25 --------- basis/xml/dispatch/dispatch-tests.factor | 33 ------------ basis/xml/dispatch/dispatch.factor | 32 ----------- basis/xml/literals/authors.txt | 1 - basis/xml/literals/summary.txt | 1 - basis/xml/literals/tags.txt | 2 - basis/xml/{dispatch => syntax}/authors.txt | 0 basis/xml/{dispatch => syntax}/summary.txt | 0 .../syntax-docs.factor} | 53 +++++++++++++++---- .../syntax-tests.factor} | 48 ++++++++++++++--- .../literals.factor => syntax/syntax.factor} | 47 ++++++++++++---- basis/xml/{dispatch => syntax}/tags.txt | 0 basis/xml/tests/encodings.factor | 2 +- basis/xml/tests/soap.factor | 2 +- basis/xml/tests/templating.factor | 2 +- basis/xml/tests/test.factor | 2 +- basis/xml/tests/xmltest.factor | 2 +- .../xml/{utilities => traversal}/authors.txt | 0 basis/xml/traversal/summary.txt | 1 + basis/xml/{utilities => traversal}/tags.txt | 0 .../traversal-docs.factor} | 8 +-- .../traversal-tests.factor} | 10 ++-- .../traversal.factor} | 13 +---- basis/xml/utilities/summary.txt | 1 - basis/xml/writer/writer-docs.factor | 4 +- basis/xml/writer/writer-tests.factor | 2 +- basis/xml/xml-docs.factor | 4 +- basis/xmode/code2html/code2html.factor | 2 +- basis/xmode/loader/loader.factor | 2 +- basis/xmode/loader/syntax/syntax.factor | 2 +- basis/xmode/utilities/utilities.factor | 2 +- .../space-file-decoder.factor | 2 +- extra/msxml-to-csv/msxml-to-csv.factor | 2 +- extra/svg/svg-tests.factor | 2 +- extra/svg/svg.factor | 2 +- extra/yahoo/yahoo.factor | 2 +- 56 files changed, 174 insertions(+), 187 deletions(-) delete mode 100644 basis/xml/dispatch/dispatch-docs.factor delete mode 100644 basis/xml/dispatch/dispatch-tests.factor delete mode 100644 basis/xml/dispatch/dispatch.factor delete mode 100644 basis/xml/literals/authors.txt delete mode 100644 basis/xml/literals/summary.txt delete mode 100644 basis/xml/literals/tags.txt rename basis/xml/{dispatch => syntax}/authors.txt (100%) rename basis/xml/{dispatch => syntax}/summary.txt (100%) rename basis/xml/{literals/literals-docs.factor => syntax/syntax-docs.factor} (53%) rename basis/xml/{literals/literals-tests.factor => syntax/syntax-tests.factor} (73%) rename basis/xml/{literals/literals.factor => syntax/syntax.factor} (83%) rename basis/xml/{dispatch => syntax}/tags.txt (100%) rename basis/xml/{utilities => traversal}/authors.txt (100%) create mode 100644 basis/xml/traversal/summary.txt rename basis/xml/{utilities => traversal}/tags.txt (100%) rename basis/xml/{utilities/utilities-docs.factor => traversal/traversal-docs.factor} (91%) rename basis/xml/{utilities/utilities-tests.factor => traversal/traversal-tests.factor} (73%) rename basis/xml/{utilities/utilities.factor => traversal/traversal.factor} (86%) delete mode 100644 basis/xml/utilities/summary.txt diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 49c4dab0db..60a9f785e6 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities xml.data ; +urls.encoding assocs xml.traversal xml.data ; IN: farkup.tests relative-link-prefix off diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index bad41296ee..a5951a5080 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators io io.streams.string kernel math namespaces peg peg.ebnf -sequences sequences.deep strings xml.entities xml.literals +sequences sequences.deep strings xml.entities xml.syntax vectors splitting xmode.code2html urls.encoding xml.data xml.writer ; IN: farkup diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index dd24d8dcde..6024607d37 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -7,8 +7,8 @@ xml xml.data xml.entities xml.writer -xml.utilities -xml.literals +xml.traversal +xml.syntax html.components html.elements html.forms diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 26fc4e2637..cccf320e44 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger html xml.literals xml.writer ; +sorting debugger html xml.syntax xml.writer ; IN: help.html : escape-char ( ch -- ) diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index ce4bddde6a..b432cc0cc6 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index f811343df2..82bb75015e 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes classes.tuple words arrays sequences splitting mirrors hashtables combinators continuations math strings inspector fry locals calendar calendar.format xml.entities xml.data -validators urls present xml.writer xml.literals xml +validators urls present xml.writer xml.syntax xml xmode.code2html lcs.diff2html farkup io.streams.string html html.streams html.forms ; IN: html.components diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index e23d929d6d..85df4f7b27 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -xml.data xml.literals urls math math.parser combinators +xml.data urls math math.parser combinators present fry io.streams.string xml.writer html ; IN: html.elements diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 0a69e2ed70..d5c744beab 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables io mirrors math fry sequences words continuations -xml.entities xml.writer xml.literals ; +xml.entities xml.writer xml.syntax ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/basis/html/html.factor b/basis/html/html.factor index 5e86add10e..e86b4917d7 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel xml.data xml.writer xml.literals urls.encoding ; +USING: kernel xml.data xml.writer xml.syntax urls.encoding ; IN: html : simple-page ( title head body -- xml ) @@ -21,4 +21,4 @@ IN: html [XML <-> XML] ; : simple-link ( xml url -- xml' ) - url-encode swap [XML ><-> XML] ; \ No newline at end of file + url-encode swap [XML ><-> XML] ; diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 0a4b8eddd4..28d6e6d5de 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel assocs io io.styles math math.order math.parser -sequences strings make words combinators macros xml.literals html fry +sequences strings make words combinators macros xml.syntax html fry destructors ; IN: html.streams diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index e5b40fcfaa..6ab6722afe 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -5,7 +5,7 @@ namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging continuations -xml.data xml.writer xml.literals strings +xml.data xml.writer xml.syntax strings html.forms html html.elements diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index c2ecd4506b..f149c3fe47 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -5,7 +5,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls -multiline xml xml.data xml.writer xml.utilities +multiline xml xml.data xml.writer xml.syntax html.components html.templates ; diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index efaf8d6a62..4aca73cc57 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -3,7 +3,7 @@ USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences arrays strings html io.streams.string -quotations xml.data xml.writer xml.literals ; +quotations xml.data xml.writer xml.syntax ; IN: html.templates MIXIN: template diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index f593980467..49acdb639c 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -299,7 +299,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.forms -xml xml.utilities validators +xml xml.traversal validators furnace furnace.conversations ; SYMBOL: a diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor index c9b4600ac8..3902b7f5e2 100644 --- a/basis/http/server/responses/responses.factor +++ b/basis/http/server/responses/responses.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.parser http accessors kernel xml.literals xml.writer +USING: math.parser http accessors kernel xml.syntax xml.writer io io.streams.string io.encodings.utf8 ; IN: http.server.responses diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 2df8838061..53d3d4f917 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces parser sequences strings assocs hashtables debugger mime.types sorting logging calendar.format accessors splitting io io.files io.files.info io.directories io.pathnames io.encodings.binary -fry xml.entities destructors urls html xml.literals +fry xml.entities destructors urls html xml.syntax html.templates.fhtml http http.server http.server.responses http.server.redirection xml.writer ; IN: http.server.static diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index 16e6cc8d97..ca9e48eb05 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: lcs xml.literals xml.writer kernel strings ; +USING: lcs xml.syntax xml.writer kernel strings ; FROM: accessors => item>> ; FROM: io => write ; FROM: sequences => each if-empty when-empty map ; diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 4cd5ef17b3..9901fd4ce4 100755 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: xml.utilities kernel assocs math.order +USING: xml.traversal kernel assocs math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities.html io.files io - http.client namespaces make xml.literals hashtables + http.client namespaces make xml.syntax hashtables calendar.format accessors continuations urls present ; IN: syndication diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 24dfabc8ff..9632cbb1ac 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings -calendar xml.data xml.writer xml.utilities assocs math.parser -debugger calendar.format math.order xml.literals xml.dispatch ; +calendar xml.data xml.writer xml.traversal assocs math.parser +debugger calendar.format math.order xml.syntax ; IN: xml-rpc ! * Sending RPC requests diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index 639ef5591c..8c837fdf19 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types" "Simple words for manipulating names:" { $subsection names-match? } { $subsection assure-name } -"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; +"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" "XML documents and chunks are made of the following classes:" diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor deleted file mode 100644 index d3d24d736c..0000000000 --- a/basis/xml/dispatch/dispatch-docs.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax ; -IN: xml.dispatch - -ABOUT: "xml.dispatch" - -ARTICLE: "xml.dispatch" "Dispatch on XML tag names" -"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" -{ $subsection POSTPONE: TAGS: } -"and to define a new 'method' for this word, use" -{ $subsection POSTPONE: TAG: } ; - -HELP: TAGS: -{ $syntax "TAGS: word" } -{ $values { "word" "a new word to define" } } -{ $description "Creates a new word to which dispatches on XML tag names." } -{ $see-also POSTPONE: TAG: } ; - -HELP: TAG: -{ $syntax "TAG: tag word definition... ;" } -{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } -{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } -{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } -{ $see-also POSTPONE: TAGS: } ; diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor deleted file mode 100644 index e76a759291..0000000000 --- a/basis/xml/dispatch/dispatch-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: xml io kernel math sequences strings xml.utilities -tools.test math.parser xml.dispatch ; -IN: xml.dispatch.tests - -TAGS: calculate ( tag -- n ) - -: calc-2children ( tag -- n n ) - children-tags first2 [ calculate ] dip calculate ; - -TAG: number calculate - children>string string>number ; -TAG: add calculate - calc-2children + ; -TAG: minus calculate - calc-2children - ; -TAG: times calculate - calc-2children * ; -TAG: divide calculate - calc-2children / ; -TAG: neg calculate - children-tags first calculate neg ; - -: calc-arith ( string -- n ) - string>xml first-child-tag calculate ; - -[ 32 ] [ - "13-8" - calc-arith -] unit-test - -\ calc-arith must-infer diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor deleted file mode 100644 index af47f7c14c..0000000000 --- a/basis/xml/dispatch/dispatch.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: words assocs kernel accessors parser sequences summary -lexer splitting fry combinators locals ; -IN: xml.dispatch - -TUPLE: no-tag name word ; -M: no-tag summary - drop "The tag-dispatching word has no method for the given tag name" ; - -alist swap '[ _ no-tag boa throw ] suffix - '[ dup main>> _ case ] ; - -PRIVATE> - -: define-tags ( word -- ) - dup dup "xtable" word-prop compile-tags define ; - -:: define-tag ( string word quot -- ) - quot string word "xtable" word-prop set-at - word define-tags ; - -: TAGS: - CREATE - [ H{ } clone "xtable" set-word-prop ] - [ define-tags ] bi ; parsing - -: TAG: - scan scan-word parse-definition define-tag ; parsing diff --git a/basis/xml/literals/authors.txt b/basis/xml/literals/authors.txt deleted file mode 100644 index 29e79639ae..0000000000 --- a/basis/xml/literals/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg \ No newline at end of file diff --git a/basis/xml/literals/summary.txt b/basis/xml/literals/summary.txt deleted file mode 100644 index 7c18fc8c76..0000000000 --- a/basis/xml/literals/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Syntax for XML interpolation diff --git a/basis/xml/literals/tags.txt b/basis/xml/literals/tags.txt deleted file mode 100644 index d236e9679f..0000000000 --- a/basis/xml/literals/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -syntax -enterprise diff --git a/basis/xml/dispatch/authors.txt b/basis/xml/syntax/authors.txt similarity index 100% rename from basis/xml/dispatch/authors.txt rename to basis/xml/syntax/authors.txt diff --git a/basis/xml/dispatch/summary.txt b/basis/xml/syntax/summary.txt similarity index 100% rename from basis/xml/dispatch/summary.txt rename to basis/xml/syntax/summary.txt diff --git a/basis/xml/literals/literals-docs.factor b/basis/xml/syntax/syntax-docs.factor similarity index 53% rename from basis/xml/literals/literals-docs.factor rename to basis/xml/syntax/syntax-docs.factor index a37fcbd711..19f059078b 100644 --- a/basis/xml/literals/literals-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -1,29 +1,56 @@ -USING: help.markup help.syntax present multiline xml.data ; -IN: xml.literals +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax xml.data present multiline ; +IN: xml.syntax -ABOUT: "xml.literals" +ABOUT: "xml.syntax" -ARTICLE: "xml.literals" "XML literals" -"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:" +ARTICLE: "xml.syntax" "Syntax extensions for XML" +"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing." +{ $subsection { "xml.syntax" "tags" } } +{ $subsection { "xml.syntax" "literals" } } +{ $subsection POSTPONE: XML-NS: } ; + +ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names" +"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" +{ $subsection POSTPONE: TAGS: } +"and to define a new 'method' for this word, use" +{ $subsection POSTPONE: TAG: } ; + +HELP: TAGS: +{ $syntax "TAGS: word" } +{ $values { "word" "a new word to define" } } +{ $description "Creates a new word to which dispatches on XML tag names." } +{ $see-also POSTPONE: TAG: } ; + +HELP: TAG: +{ $syntax "TAG: tag word definition... ;" } +{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } +{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } +{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } +{ $see-also POSTPONE: TAGS: } ; + +ARTICLE: { "xml.syntax" "literals" } "XML literals" +"The following words provide syntax for XML literals:" { $subsection POSTPONE: ... XML>" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; HELP: [XML { $syntax "[XML foo ... bar ... baz XML]" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; -ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax" +ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax" "XML interpolation has two forms for each of the words " { $link POSTPONE: " } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles." $nl "These forms can be used where a tag might go, as in " { $snippet "[XML <-> XML]" } " or where an attribute might go, as in " { $snippet "[XML /> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" { $example -{" USING: splitting sequences xml.writer xml.literals ; +{" USING: splitting sequences xml.writer xml.syntax ; "one two three" " " split [ [XML <-> XML] ] map <-> XML> pprint-xml"} @@ -41,7 +68,7 @@ $nl "} } "Here is an example of the locals version:" { $example -{" USING: locals urls xml.literals xml.writer ; +{" USING: locals urls xml.syntax xml.writer ; [let | number [ 3 ] false [ f ] @@ -58,3 +85,7 @@ $nl XML> pprint-xml ] "} {" "} } ; + +HELP: XML-NS: +{ $syntax "XML-NS: name http://url" } +{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ; diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/syntax/syntax-tests.factor similarity index 73% rename from basis/xml/literals/literals-tests.factor rename to basis/xml/syntax/syntax-tests.factor index 0d8367c144..10ab961ec0 100644 --- a/basis/xml/literals/literals-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -1,9 +1,45 @@ -! Copyright (C) 2009 Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test xml.literals multiline kernel assocs -sequences accessors xml.writer xml.literals.private -locals splitting urls xml.data classes ; -IN: xml.literals.tests +USING: xml io kernel math sequences strings xml.traversal +tools.test math.parser xml.syntax xml.data xml.syntax.private +accessors multiline locals inverse xml.writer splitting classes ; +IN: xml.syntax.tests + +! TAGS test + +TAGS: calculate ( tag -- n ) + +: calc-2children ( tag -- n n ) + children-tags first2 [ calculate ] dip calculate ; + +TAG: number calculate + children>string string>number ; +TAG: add calculate + calc-2children + ; +TAG: minus calculate + calc-2children - ; +TAG: times calculate + calc-2children * ; +TAG: divide calculate + calc-2children / ; +TAG: neg calculate + children-tags first calculate neg ; + +: calc-arith ( string -- n ) + string>xml first-child-tag calculate ; + +[ 32 ] [ + "13-8" + calc-arith +] unit-test + +\ calc-arith must-infer + +XML-NS: foo http://blah.com + +[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test + +! XML literals [ "a" "c" { "a" "c" f } ] [ "<-a->/><->" @@ -47,7 +83,7 @@ IN: xml.literals.tests [ {" "} ] -[ 3 f URL" http://factorcode.org/" "hello" \ drop +[ 3 f "http://factorcode.org/" "hello" \ drop false=<-> url=<-> string=<-> word=<->/> XML> pprint-xml>string ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/syntax/syntax.factor similarity index 83% rename from basis/xml/literals/literals.factor rename to basis/xml/syntax/syntax.factor index 4648f7b0e7..8e6bebfe6b 100644 --- a/basis/xml/literals/literals.factor +++ b/basis/xml/syntax/syntax.factor @@ -1,11 +1,42 @@ -! Copyright (C) 2009 Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.state kernel sequences fry assocs xml.data -accessors strings make multiline parser namespaces macros -sequences.deep generalizations words combinators -math present arrays unicode.categories locals.backend -quotations ; -IN: xml.literals +USING: words assocs kernel accessors parser sequences summary +lexer splitting combinators locals xml.data memoize sequences.deep +xml.data xml.state xml namespaces present arrays generalizations strings +make math macros multiline inverse combinators.short-circuit +sorting fry unicode.categories ; +IN: xml.syntax + +alist swap '[ _ no-tag boa throw ] suffix + '[ dup main>> _ case ] ; + +: define-tags ( word -- ) + dup dup "xtable" word-prop compile-tags define ; + +:: define-tag ( string word quot -- ) + quot string word "xtable" word-prop set-at + word define-tags ; + +PRIVATE> + +: TAGS: + CREATE + [ H{ } clone "xtable" set-word-prop ] + [ define-tags ] bi ; parsing + +: TAG: + scan scan-word parse-definition define-tag ; parsing + +: XML-NS: + CREATE-WORD (( string -- name )) over set-stack-effect + scan '[ f swap _ ] define-memoized ; parsing : [XML "XML]" [ string>chunk ] parse-def ; parsing -USING: inverse sorting fry combinators.short-circuit ; - : remove-blanks ( seq -- newseq ) [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; diff --git a/basis/xml/dispatch/tags.txt b/basis/xml/syntax/tags.txt similarity index 100% rename from basis/xml/dispatch/tags.txt rename to basis/xml/syntax/tags.txt diff --git a/basis/xml/tests/encodings.factor b/basis/xml/tests/encodings.factor index 35076d2930..aec3e40a52 100644 --- a/basis/xml/tests/encodings.factor +++ b/basis/xml/tests/encodings.factor @@ -1,4 +1,4 @@ -USING: xml xml.data xml.utilities tools.test accessors kernel +USING: xml xml.data xml.traversal tools.test accessors kernel io.encodings.8-bit ; [ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test diff --git a/basis/xml/tests/soap.factor b/basis/xml/tests/soap.factor index d2568a24e1..3d1ac2379e 100644 --- a/basis/xml/tests/soap.factor +++ b/basis/xml/tests/soap.factor @@ -1,4 +1,4 @@ -USING: sequences xml kernel arrays xml.utilities io.files tools.test ; +USING: sequences xml kernel arrays xml.traversal io.files tools.test ; IN: xml.tests : assemble-data ( tag -- 3array ) diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor index 618e785d05..4861f86d7b 100644 --- a/basis/xml/tests/templating.factor +++ b/basis/xml/tests/templating.factor @@ -1,5 +1,5 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry -accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ; +accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ; IN: xml.tests : sub-tag diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index dcd428d9e6..b1f6cf002f 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.utilities continuations assocs +xml.traversal continuations assocs sequences.deep accessors io.streams.string ; ! This is insufficient diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index a8024ce151..80472fc788 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,6 +1,6 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays xml.data ; +xml.traversal xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; diff --git a/basis/xml/utilities/authors.txt b/basis/xml/traversal/authors.txt similarity index 100% rename from basis/xml/utilities/authors.txt rename to basis/xml/traversal/authors.txt diff --git a/basis/xml/traversal/summary.txt b/basis/xml/traversal/summary.txt new file mode 100644 index 0000000000..365ec87864 --- /dev/null +++ b/basis/xml/traversal/summary.txt @@ -0,0 +1 @@ +Utilities for traversing an XML DOM tree diff --git a/basis/xml/utilities/tags.txt b/basis/xml/traversal/tags.txt similarity index 100% rename from basis/xml/utilities/tags.txt rename to basis/xml/traversal/tags.txt diff --git a/basis/xml/utilities/utilities-docs.factor b/basis/xml/traversal/traversal-docs.factor similarity index 91% rename from basis/xml/utilities/utilities-docs.factor rename to basis/xml/traversal/traversal-docs.factor index 161ca824c3..1329c4975e 100644 --- a/basis/xml/utilities/utilities-docs.factor +++ b/basis/xml/traversal/traversal-docs.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax xml.data sequences strings ; -IN: xml.utilities +IN: xml.traversal -ABOUT: "xml.utilities" +ABOUT: "xml.traversal" -ARTICLE: "xml.utilities" "Utilities for processing XML" - "Getting parts of an XML document or tag:" +ARTICLE: "xml.traversal" "Utilities for traversing XML" + "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:" $nl "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." { $subsection tag-named } diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/traversal/traversal-tests.factor similarity index 73% rename from basis/xml/utilities/utilities-tests.factor rename to basis/xml/traversal/traversal-tests.factor index 673bf47f6e..165ca34adf 100644 --- a/basis/xml/utilities/utilities-tests.factor +++ b/basis/xml/traversal/traversal-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.utilities tools.test xml.data sequences ; -IN: xml.utilities.tests +USING: xml xml.traversal tools.test xml.data sequences ; +IN: xml.traversal.tests [ "bar" ] [ "bar" string>xml children>string ] unit-test @@ -9,14 +9,10 @@ IN: xml.utilities.tests [ "" ] [ "" string>xml children>string ] unit-test -XML-NS: foo http://blah.com - -[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test - [ "blah" ] [ "" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test [ { "blah" } ] [ "" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test [ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test -[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test \ No newline at end of file +[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/traversal/traversal.factor similarity index 86% rename from basis/xml/utilities/utilities.factor rename to basis/xml/traversal/traversal.factor index 1249da8c36..b337ea1472 100755 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/traversal/traversal.factor @@ -3,7 +3,7 @@ USING: accessors kernel namespaces sequences words io assocs quotations strings parser lexer arrays xml.data xml.writer debugger splitting vectors sequences.deep combinators fry memoize ; -IN: xml.utilities +IN: xml.traversal : children>string ( tag -- string ) children>> { @@ -66,14 +66,3 @@ PRIVATE> : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ; - -: insert-children ( children tag -- ) - dup children>> [ push-all ] - [ swap V{ } like >>children drop ] if ; - -: insert-child ( child tag -- ) - [ 1vector ] dip insert-children ; - -: XML-NS: - CREATE-WORD (( string -- name )) over set-stack-effect - scan '[ f swap _ ] define-memoized ; parsing diff --git a/basis/xml/utilities/summary.txt b/basis/xml/utilities/summary.txt deleted file mode 100644 index a671132945..0000000000 --- a/basis/xml/utilities/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Utilities for manipulating an XML DOM tree diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index cc45528cec..9971abcdf1 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -41,7 +41,7 @@ HELP: pprint-xml HELP: indenter { $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML bar XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" %%%%bar @@ -49,7 +49,7 @@ HELP: indenter HELP: sensitive-tags { $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML something
bing
 bang
    bong
XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index f414264e11..23fb7a5074 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer tools.test fry xml kernel multiline -xml.writer.private io.streams.string xml.utilities sequences +xml.writer.private io.streams.string xml.traversal sequences io.encodings.utf8 io.files accessors io.directories ; IN: xml.writer.tests diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 901fce2dd4..024b086ef9 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -93,7 +93,7 @@ ARTICLE: "xml" "XML parser" { $vocab-subsection "XML parsing errors" "xml.errors" } { $vocab-subsection "XML entities" "xml.entities" } { $vocab-subsection "XML data types" "xml.data" } - { $vocab-subsection "Utilities for processing XML" "xml.utilities" } - { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ; + { $vocab-subsection "Utilities for traversing XML" "xml.traversal" } + { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ; ABOUT: "xml" diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 2f35cd6d76..3fb5a532c9 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel locals io io.files sequences words io.encodings.utf8 -namespaces xml.entities accessors xml.literals locals xml.writer ; +namespaces xml.entities accessors xml.syntax locals xml.writer ; IN: xmode.code2html : htmlize-tokens ( tokens -- xml ) diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index b661f4eb3f..70466913a0 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -1,5 +1,5 @@ USING: xmode.loader.syntax xmode.tokens xmode.rules -xmode.keyword-map xml.data xml.utilities xml assocs kernel +xmode.keyword-map xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces parser xmode.utilities parser-combinators.regexp io.files accessors ; IN: xmode.loader diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index b546969a37..0e7293da97 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors xmode.tokens xmode.rules xmode.keyword-map -xml.data xml.utilities xml assocs kernel combinators sequences +xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces make parser lexer xmode.utilities parser-combinators.regexp io.files splitting arrays ; IN: xmode.loader.syntax diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index d6407d8180..2423fb0d86 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -1,5 +1,5 @@ USING: accessors sequences assocs kernel quotations namespaces -xml.data xml.utilities combinators macros parser lexer words fry ; +xml.data xml.traversal combinators macros parser lexer words fry ; IN: xmode.utilities : implies ( x y -- z ) [ not ] dip or ; inline diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor index ecc8f778fa..e85830de52 100755 --- a/extra/4DNav/space-file-decoder/space-file-decoder.factor +++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Jeff Bigot ! See http://factorcode.org/license.txt for BSD license. -USING: adsoda xml xml.utilities xml.dispatch accessors +USING: adsoda xml xml.traversal xml.syntax accessors combinators sequences math.parser kernel splitting values continuations ; IN: 4DNav.space-file-decoder diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 855275efcc..cab28c14ca 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,4 +1,4 @@ -USING: io io.files sequences xml xml.utilities +USING: io io.files sequences xml xml.traversal io.encodings.ascii kernel ; IN: msxml-to-csv diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 3a28310d71..0f0c349b8e 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays literals math math.affine-transforms -math.functions multiline sequences svg tools.test xml xml.utilities ; +math.functions multiline sequences svg tools.test xml xml.traversal ; IN: svg.tests { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 4d8a6e6a17..2ed5d21707 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish -splitting strings xml.data xml.utilities ; +splitting strings xml.data xml.syntax ; IN: svg XML-NS: svg-name http://www.w3.org/2000/svg diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index d163c8f1ac..b58a11747f 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. -USING: http.client xml xml.utilities kernel sequences +USING: http.client xml xml.traversal kernel sequences math.parser urls accessors locals ; IN: yahoo From 51b5973b0e356392462aa1385a36e8925dafb863 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 21:26:40 -0600 Subject: [PATCH 025/170] Documenting XML interpolation inverse --- basis/xml/syntax/syntax-docs.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor index 19f059078b..34473fecfc 100644 --- a/basis/xml/syntax/syntax-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -84,7 +84,17 @@ $nl word=<-word-> /> XML> pprint-xml ] "} {" -"} } ; +"} } +"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:" +{ $example {" USING: sequences xml.syntax inverse ; +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "yes" ] } + { [ [XML /> XML] ] [ "no" prepend ] } + } switch ; +[XML pple XML] dispatch write "} "apple" } ; HELP: XML-NS: { $syntax "XML-NS: name http://url" } From 67ffc894021de130614cb9d0425d6c8c8681ce62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Feb 2009 22:19:52 -0600 Subject: [PATCH 026/170] colors.constants: defines a COLOR: word which looks up colors in X11 rgb.txt --- basis/colors/constants/authors.txt | 1 + basis/colors/constants/constants-tests.factor | 6 + basis/colors/constants/constants.factor | 31 + basis/colors/constants/rgb.txt | 753 ++++++++++++++++++ basis/colors/constants/summary.txt | 1 + 5 files changed, 792 insertions(+) create mode 100644 basis/colors/constants/authors.txt create mode 100644 basis/colors/constants/constants-tests.factor create mode 100644 basis/colors/constants/constants.factor create mode 100644 basis/colors/constants/rgb.txt create mode 100644 basis/colors/constants/summary.txt diff --git a/basis/colors/constants/authors.txt b/basis/colors/constants/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/colors/constants/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/colors/constants/constants-tests.factor b/basis/colors/constants/constants-tests.factor new file mode 100644 index 0000000000..08b05a34e7 --- /dev/null +++ b/basis/colors/constants/constants-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test colors.constants colors ; +IN: colors.constants.tests + +[ t ] [ COLOR: light-green rgba? ] unit-test \ No newline at end of file diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor new file mode 100644 index 0000000000..e298b3b61e --- /dev/null +++ b/basis/colors/constants/constants.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs math math.parser memoize +io.encodings.ascii io.files lexer parser +colors sequences splitting combinators.smart ascii ; +IN: colors.constants + +number 255 /f ] tri@ 1.0 ] dip + [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap + ] inputassoc ; + +MEMO: rgb.txt ( -- assoc ) + "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ; + +PRIVATE> + +ERROR: no-such-color name ; + +: named-color ( name -- rgb ) + dup rgb.txt at [ ] [ no-such-color ] ?if ; + +: COLOR: scan named-color parsed ; parsing \ No newline at end of file diff --git a/basis/colors/constants/rgb.txt b/basis/colors/constants/rgb.txt new file mode 100644 index 0000000000..62eb8961ec --- /dev/null +++ b/basis/colors/constants/rgb.txt @@ -0,0 +1,753 @@ +! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $ +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 +169 169 169 dark grey +169 169 169 DarkGrey +169 169 169 dark gray +169 169 169 DarkGray +0 0 139 dark blue +0 0 139 DarkBlue +0 139 139 dark cyan +0 139 139 DarkCyan +139 0 139 dark magenta +139 0 139 DarkMagenta +139 0 0 dark red +139 0 0 DarkRed +144 238 144 light green +144 238 144 LightGreen diff --git a/basis/colors/constants/summary.txt b/basis/colors/constants/summary.txt new file mode 100644 index 0000000000..5551048750 --- /dev/null +++ b/basis/colors/constants/summary.txt @@ -0,0 +1 @@ +A utility to look up colors in the X11 rgb.txt color database From a1f4f7772f988f7fd0cf84598a378747807acb01 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Feb 2009 23:59:36 -0600 Subject: [PATCH 027/170] make multipart work with sessions --- basis/mime/multipart/multipart.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index fc3024bd01..eda7849a73 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ; dup name>> empty-name? [ drop ] [ - [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] + [ name-content>> ] [ name>> unquote ] [ mime-parts>> set-at ] tri ] if ; From f31e19a66669c1c280858755a3a483eededd7490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 00:01:28 -0600 Subject: [PATCH 028/170] refactoring graphics.bitmap --- extra/graphics/bitmap/bitmap-tests.factor | 15 +++ extra/graphics/bitmap/bitmap.factor | 155 +++++++++------------- extra/graphics/viewer/viewer.factor | 33 ++++- 3 files changed, 108 insertions(+), 95 deletions(-) create mode 100644 extra/graphics/bitmap/bitmap-tests.factor diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..4998427b22 --- /dev/null +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -0,0 +1,15 @@ +USING: graphics.bitmap ; +IN: graphics.bitmap.tests + +: test-bitmap24 ( -- ) + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; + +: test-bitmap8 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; + +: test-bitmap4 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; + +: test-bitmap1 ( -- ) + "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; + diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index a0212e47de..bd34a9ee41 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays combinators summary -graphics.viewer io io.binary io.files kernel libc math +io io.binary io.files kernel libc math math.functions math.bitwise namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes fry io.encodings.binary accessors grouping macros alien.c-types ; @@ -12,10 +12,11 @@ IN: graphics.bitmap ! Handles row-reversed bitmaps (their height is negative) TUPLE: bitmap magic size reserved offset header-length width - height planes bit-count compression size-image - x-pels y-pels color-used color-important rgb-quads color-index array ; +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +array ; -: (array-copy) ( bitmap array -- bitmap array' ) +: array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; MACRO: (nbits>bitmap) ( bits -- ) @@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- ) 2over * _ * >>size-image swap >>height swap >>width - swap (array-copy) [ >>array ] [ >>color-index ] bi + swap array-copy [ >>array ] [ >>color-index ] bi _ >>bit-count ] ; @@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- ) : raw-bitmap>array ( bitmap -- array ) dup bit-count>> { - { 32 [ "32bit" throw ] } + { 32 [ color-index>> ] } { 24 [ color-index>> ] } { 16 [ "16bit" throw ] } { 8 [ 8bit>array ] } @@ -59,107 +60,75 @@ ERROR: bitmap-magic ; M: bitmap-magic summary drop "First two bytes of bitmap stream must be 'BM'" ; -: parse-file-header ( bitmap -- ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - 4 read le> >>size - 4 read le> >>reserved - 4 read le> >>offset drop ; +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; -: parse-bitmap-header ( bitmap -- ) - 4 read le> >>header-length - 4 read signed-le> >>width - 4 read signed-le> >>height - 2 read le> >>planes - 2 read le> >>bit-count - 4 read le> >>compression - 4 read le> >>size-image - 4 read le> >>x-pels - 4 read le> >>y-pels - 4 read le> >>color-used - 4 read le> >>color-important drop ; +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; : rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] keep header-length>> - ; + [ offset>> 14 - ] [ header-length>> ] bi - ; : color-index-length ( bitmap -- n ) - [ width>> ] keep [ planes>> * ] keep - [ bit-count>> * 31 + 32 /i 4 * ] keep - height>> abs * ; + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; -: parse-bitmap ( bitmap -- ) +: parse-bitmap ( bitmap -- bitmap ) dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index drop ; + dup color-index-length read >>color-index ; : load-bitmap ( path -- bitmap ) binary [ bitmap new - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader dup raw-bitmap>array >>array ; +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + : save-bitmap ( bitmap path -- ) binary [ - "BM" >byte-array write - dup array>> length 14 + 40 + 4 >le write - 0 4 >le write - 54 4 >le write - - 40 4 >le write - { - [ width>> 4 >le write ] - [ height>> 4 >le write ] - [ planes>> 1 or 2 >le write ] - [ bit-count>> 24 or 2 >le write ] - [ compression>> 0 or 4 >le write ] - [ size-image>> 4 >le write ] - [ x-pels>> 0 or 4 >le write ] - [ y-pels>> 0 or 4 >le write ] - [ color-used>> 0 or 4 >le write ] - [ color-important>> 0 or 4 >le write ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave + B{ CHAR: B CHAR: M } write + [ + array>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi ] with-file-writer ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; - -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; - -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; - -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; - diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 0533ffaf5d..8e0b1ec43c 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions namespaces opengl -ui.gadgets ui.render accessors ; +USING: accessors arrays combinators graphics.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- ) : ( bitmap -- gadget ) \ graphics-gadget new-gadget swap >>image ; + +M: bitmap draw-image ( bitmap -- ) + dup height>> 0 < [ + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 over height>> abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + [ width>> ] keep + [ + [ height>> abs ] keep + bit-count>> { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case + ] keep array>> glDrawPixels ; + +M: bitmap width ( bitmap -- ) width>> ; +M: bitmap height ( bitmap -- ) height>> ; + +: bitmap. ( path -- ) + load-bitmap gadget. ; + +: bitmap-window ( path -- gadget ) + load-bitmap [ "bitmap" open-window ] keep ; From 28e644209c1c82c5e59cd49bf0680999f45c79bc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 6 Feb 2009 00:42:46 -0600 Subject: [PATCH 029/170] Unicode.case supports lithuanian properly (hopefully) --- basis/unicode/case/case-tests.factor | 16 +++++++++++++-- basis/unicode/case/case.factor | 30 ++++++++++++++++++---------- 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 6e26a36a19..52a8d9755e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -1,4 +1,7 @@ -USING: unicode.case tools.test namespaces ; +! Copyright (C) 2008, 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ; +IN: unicode.case.tests \ >upper must-infer \ >lower must-infer @@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ; [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test [ + [ f ] [ i-dot? ] unit-test + [ f ] [ lt? ] unit-test "tr" locale set + [ t ] [ i-dot? ] unit-test + [ f ] [ lt? ] unit-test [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test "lt" locale set - ! Lithuanian casing tests + [ f ] [ i-dot? ] unit-test + [ t ] [ lt? ] unit-test + [ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test + [ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test + [ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test +! [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test ] with-scope [ t ] [ "asdf" lower? ] unit-test diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 65fab0ac38..3ac98cd57f 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Daniel Ehrenberg. +! Copyright (C) 2008, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: unicode.data sequences namespaces sbufs make unicode.syntax unicode.normalize math hints -unicode.categories combinators unicode.syntax assocs +unicode.categories combinators unicode.syntax assocs combinators.short-circuit strings splitting kernel accessors unicode.breaks fry locals ; QUALIFIED: ascii IN: unicode.case @@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall? : i-dot? ( -- ? ) locale get { "tr" "az" } member? ; +: lt? ( -- ? ) + locale get "lt" = ; + : lithuanian? ( -- ? ) locale get "lt" = ; : dot-over ( -- ch ) HEX: 307 ; @@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall? : mark-above? ( ch -- ? ) combining-class 230 = ; -: with-rest ( seq quot: ( seq -- seq ) -- seq ) - [ unclip ] dip swap slip prefix ; inline +:: with-rest ( seq quot: ( seq -- seq ) -- seq ) + seq unclip quot dip prefix ; inline : add-dots ( seq -- seq ) - [ [ "" ] [ - dup first mark-above? - [ CHAR: combining-dot-above prefix ] when + [ [ { } ] [ + [ + dup first + { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1|| + [ CHAR: combining-dot-above prefix ] when + ] map ] if-empty ] with-rest ; inline : lithuanian>lower ( string -- lower ) - "i" split add-dots "i" join - "j" split add-dots "i" join ; inline + "I" split add-dots "I" join + "J" split add-dots "J" join ; inline : turk>upper ( string -- upper-i ) "i" "I\u000307" replace ; inline @@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall? PRIVATE> : >lower ( string -- lower ) - i-dot? [ turk>lower ] when final-sigma + i-dot? [ turk>lower ] when + lt? [ lithuanian>lower ] when + final-sigma [ lower>> ] [ ch>lower ] map-case ; HINTS: >lower string ; : >upper ( string -- upper ) i-dot? [ turk>upper ] when + lt? [ lithuanian>upper ] when [ upper>> ] [ ch>upper ] map-case ; HINTS: >upper string ; @@ -103,6 +112,7 @@ HINTS: >upper string ; : (>title) ( string -- title ) i-dot? [ turk>upper ] when + lt? [ lithuanian>upper ] when [ title>> ] [ ch>title ] map-case ; inline : title-word ( string -- title ) From 4adef7db09688f341283c2081b87faa0cd4b40da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 02:45:21 -0600 Subject: [PATCH 030/170] Fix functors bug where changing a hand-written method into one generated by a functor would forget the method; also associate functor-generated methods with the source file they're in. Add DEFINES-CLASS, to parallel DEFINES. Update math.blas and specialized-arrays/vectors to use DEFINES-CLASS where appropriate --- basis/functors/functors-tests.factor | 51 +++++++++++++++++-- basis/functors/functors.factor | 11 ++-- basis/math/blas/matrices/matrices.factor | 2 +- basis/math/blas/vectors/vectors.factor | 2 +- .../direct/functor/functor.factor | 2 +- .../specialized-arrays/functor/functor.factor | 2 +- .../functor/functor.factor | 2 +- 7 files changed, 60 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a5f3042b38..df008d52bd 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,11 +1,12 @@ IN: functors.tests -USING: functors tools.test math words kernel ; +USING: functors tools.test math words kernel multiline parser +io.streams.string generic ; << FUNCTOR: define-box ( T -- ) -B DEFINES ${T}-box +B DEFINES-CLASS ${T}-box DEFINES <${B}> WHERE @@ -62,4 +63,48 @@ WHERE >> -[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file +[ 4 ] [ 1 3 blah ] unit-test + +GENERIC: some-generic ( a -- b ) + +! Does replacing an ordinary word with a functor-generated one work? +[ [ ] ] [ + <" IN: functors.tests + + TUPLE: some-tuple ; + : some-word ( -- ) ; + M: some-tuple some-generic ; + "> "functors-test" parse-stream +] unit-test + +: test-redefinition ( -- ) + [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ + "some-tuple" "functors.tests" lookup + "some-generic" "functors.tests" lookup method >boolean + ] unit-test ; + +test-redefinition + +FUNCTOR: redefine-test ( W -- ) + +W-word DEFINES ${W}-word +W-tuple DEFINES-CLASS ${W}-tuple +W-generic IS ${W}-generic + +WHERE + +TUPLE: W-tuple ; +: W-word ( -- ) ; +M: W-tuple W-generic ; + +;FUNCTOR + +[ [ ] ] [ + <" IN: functors.tests + << "some" redefine-test >> + "> "functors-test" parse-stream +] unit-test + +test-redefinition \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index f4d35b6932..14151692f0 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -3,8 +3,9 @@ USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser arrays accessors ; +effects.parser locals.types locals.parser generic.parser +locals.rewrite.closures vocabs.parser classes.parser +arrays accessors ; IN: functors ! This is a hack @@ -29,7 +30,7 @@ M: object >fake-quotations ; GENERIC: fake-quotations> ( fake -- quot ) M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] map >quotation ; + seq>> [ fake-quotations> ] [ ] map-as ; M: array fake-quotations> [ fake-quotations> ] map ; @@ -57,7 +58,7 @@ M: object fake-quotations> ; effect off scan-param parsed scan-param parsed - \ create-method parsed + \ create-method-in parsed parse-definition* DEFINE* ; parsing @@ -96,6 +97,8 @@ PRIVATE> : DEFINES [ create-in ] (INTERPOLATE) ; parsing +: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing + DEFER: ;FUNCTOR delimiter DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix XMATRIX{ DEFINES ${T}matrix{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3b7f89f730..4e61f4478e 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy XSWAP IS cblas_${T}swap IXAMAX IS cblas_i${T}amax -VECTOR DEFINES ${TYPE}-blas-vector +VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index ce23186fc6..0c3999db44 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -11,7 +11,7 @@ A' IS ${T}-array >A' IS >${T}-array IS <${A'}> -A DEFINES direct-${T}-array +A DEFINES-CLASS direct-${T}-array DEFINES <${A}> NTH [ T dup c-getter array-accessor ] diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 9a56346be4..3c2c53db31 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -15,7 +15,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array +A DEFINES-CLASS ${T}-array DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 2410cc284e..9d48a9e79e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- ) A IS ${T}-array IS <${A}> -V DEFINES ${T}-vector +V DEFINES-CLASS ${T}-vector DEFINES <${V}> >V DEFINES >${V} V{ DEFINES ${V}{ From 7bb0e78314e21b1094cbbc3aaa1cd766f5100e0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:02:00 -0600 Subject: [PATCH 031/170] Add support for C99 complex float and complex double types to FFI They are named complex-float and complex-double in the Factor world --- basis/alien/arrays/arrays.factor | 17 ++++++++--------- basis/alien/c-types/c-types-docs.factor | 2 ++ basis/alien/structs/structs.factor | 11 +++++++++-- basis/compiler/codegen/codegen.factor | 4 ++-- basis/compiler/tests/alien.factor | 7 +++++++ vm/ffi_test.c | 6 +++++- vm/ffi_test.h | 2 ++ vm/master.h | 1 + 8 files changed, 36 insertions(+), 14 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 727492edb1..c823b614d9 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 make libc cpu.architecture ; +sequences math kernel namespaces fry libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -10,7 +10,7 @@ M: array c-type ; M: array c-type-class drop object ; -M: array heap-size unclip heap-size [ * ] reduce ; +M: array heap-size unclip [ product ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; +M: array c-type-boxer-quot drop f ; + +M: array c-type-unboxer-quot drop f ; + M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-boxer-quot drop f ; - -M: value-type c-type-unboxer-quot drop f ; - M: value-type c-type-getter drop [ swap ] ; M: value-type c-type-setter ( type -- quot ) - [ - dup c-type-getter % \ swap , heap-size , \ memcpy , - ] [ ] make ; + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index a2b555b057..dc29ea9bb3 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -178,6 +178,8 @@ $nl { { $snippet "ulonglong" } { } } { { $snippet "float" } { } } { { $snippet "double" } { "same format as " { $link float } " objects" } } + { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } + { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..d9ed53d0c6 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs -TUPLE: struct-type size align fields ; +TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; M: struct-type heap-size size>> ; @@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; +M: struct-type c-type-boxer-quot boxer-quot>> ; + +M: struct-type c-type-unboxer-quot unboxer-quot>> ; + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -40,7 +44,10 @@ M: struct-type stack-size : (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip - struct-type boa + struct-type new + swap >>fields + swap >>align + swap >>size swap typedef ; : make-fields ( name vocab fields -- fields ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 71d9c36412..d915b29ae5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,8 +3,8 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays sets libc continuations.private -fry cpu.architecture +alien.strings alien.arrays alien.complex sets libc +continuations.private fry cpu.architecture compiler.errors compiler.alien compiler.cfg diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1b21e40bac..b1a9853d55 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -558,3 +558,10 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; [ ] [ stack-frame-bustage 2drop ] unit-test + +FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ; + +[ C{ 4.0 4.0 } ] [ + C{ 1.0 2.0 } + C{ 1.5 1.0 } ffi_test_45 +] unit-test \ No newline at end of file diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 1ec41ac2b9..36147795d1 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,6 +1,5 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include #include "master.h" #include "ffi_test.h" @@ -303,3 +302,8 @@ struct test_struct_14 ffi_test_44(void) retval.x2 = 2.0; return retval; } + +complex float ffi_test_45(complex float x, complex double y) +{ + return x + 2 * y; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 7c51261157..de48d6dc5b 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -88,3 +88,5 @@ struct test_struct_16 { float x; int a; }; DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); + +complex float ffi_test_45(complex float x, complex double y); diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..01b2335841 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,6 +8,7 @@ #include #include #include +#include #include #include From 7ffbbb13e0ffc533ab7086966cbca975f4f2866d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:36:17 -0600 Subject: [PATCH 032/170] Specialized arrays can now be passed to alien functions directly, without calling underlying>> first --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 9 +++++---- core/alien/alien.factor | 10 +++++++++- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index c823b614d9..8253d9458c 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -28,7 +28,7 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot drop f ; -M: array c-type-unboxer-quot drop f ; +M: array c-type-unboxer-quot drop [ >c-ptr ] ; M: value-type c-type-reg-class drop int-regs ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d1354cb04e..ff9d4cefc4 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -201,13 +201,13 @@ M: byte-array byte-length length ; 1 swap malloc-array ; inline : malloc-byte-array ( byte-array -- alien ) - dup length [ nip malloc dup ] 2keep memcpy ; + dup byte-length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) - swap dup length memcpy ; + swap dup byte-length memcpy ; : array-accessor ( type quot -- def ) [ @@ -263,7 +263,7 @@ M: long-long-type box-return ( type -- ) ] when ; : malloc-file-contents ( path -- alien len ) - binary file-contents dup malloc-byte-array swap length ; + binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline @@ -283,9 +283,10 @@ M: long-long-type box-return ( type -- ) c-ptr >>class [ alien-cell ] >>getter - [ set-alien-cell ] >>setter + [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer "void*" define-primitive-type diff --git a/core/alien/alien.factor b/core/alien/alien.factor index c97e36e889..93d1a8e306 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; @@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: >c-ptr ( obj -- c-ptr ) + +M: c-ptr >c-ptr ; + +SLOT: underlying + +M: object >c-ptr underlying>> ; + GENERIC: expired? ( c-ptr -- ? ) flushable M: alien expired? expired>> ; From d6aa376ed089ce44364ba47693ab32c7f60c9e28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:37:28 -0600 Subject: [PATCH 033/170] Removing now-redundant underlying>> calls --- basis/cocoa/messages/messages.factor | 2 +- basis/cocoa/views/views.factor | 2 +- basis/compiler/tests/alien.factor | 4 ++-- basis/db/postgresql/lib/lib.factor | 6 +++--- basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +- .../io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +- .../io/backend/unix/multiplexers/select/select.factor | 4 ++-- basis/io/launcher/windows/windows.factor | 4 ++-- basis/io/pipes/unix/unix.factor | 2 +- basis/libc/libc.factor | 4 ++-- basis/opengl/opengl.factor | 10 +++++----- basis/opengl/shaders/shaders.factor | 2 +- .../specialized-arrays/specialized-arrays-tests.factor | 7 ++++++- basis/struct-arrays/struct-arrays-tests.factor | 4 ++-- basis/unix/utilities/utilities.factor | 4 ++-- basis/windows/com/wrapper/wrapper.factor | 2 +- basis/windows/dinput/constants/constants.factor | 2 +- basis/x11/clipboard/clipboard.factor | 2 +- basis/x11/glx/glx.factor | 2 +- basis/x11/xim/xim.factor | 2 +- 20 files changed, 37 insertions(+), 32 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ebe98a2df1..a0b0e89a0d 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global [ 0 [ class_copyMethodList ] keep *uint ] dip over 0 = [ 3drop ] [ [ ] dip - [ each ] [ drop underlying>> (free) ] 2bi + [ each ] [ drop (free) ] 2bi ] if ; inline : register-objc-methods ( class -- ) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 03cafd0a0a..e74e912202 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -68,7 +68,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] int-array{ } make underlying>> + ] int-array{ } make -> initWithAttributes: -> autorelease ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b1a9853d55..b9c62f1429 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; [ 32.0 ] [ - { 1.0 2.0 3.0 } >float-array underlying>> - { 4.0 5.0 6.0 } >float-array underlying>> + { 1.0 2.0 3.0 } >float-array + { 4.0 5.0 6.0 } >float-array ffi_test_23 ] unit-test diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 19cf5c5002..05114a4deb 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>oid ] uint-array{ } map-as ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* + first2 [ >void*-array ] [ >uint-array ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as ; : do-postgresql-bound-statement ( statement -- res ) [ diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index a91f62f1df..e1428fee4d 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) ] [ 2drop f ] if ; : wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + [ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi* epoll_wait multiplexer-error ; : handle-event ( event mx -- ) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 2a6648981b..7bd157136a 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) : wait-kevent ( mx timespec -- n ) [ [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi + [ events>> dup length ] bi ] dip kevent multiplexer-error ; : handle-kevent ( mx kevent -- ) diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index c62101e478..7d0acb4140 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; M:: select-mx wait-for-events ( us mx -- ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 0497754aa2..7de6c25a13 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -103,7 +103,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] ushort-array{ } make underlying>> + ] ushort-array{ } make >>lpEnvironment ] when ; @@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as - [ length ] [ underlying>> ] bi 0 0 + [ length ] keep 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 6a0015084b..f94733ca56 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -7,5 +7,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 - [ underlying>> pipe io-error ] + [ pipe io-error ] [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index c4d351e6a0..1e751833a2 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -75,14 +75,14 @@ PRIVATE> dup add-malloc ; : realloc ( alien size -- newalien ) + [ >c-ptr ] dip over malloc-exists? [ realloc-error ] unless dupd (realloc) check-ptr swap delete-malloc dup add-malloc ; : free ( alien -- ) - dup delete-malloc - (free) ; + >c-ptr [ delete-malloc ] [ (free) ] bi ; : memcpy ( dst src size -- ) "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index f5868ee7a1..6d9ac95965 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - float-array{ } like underlying>> glMaterialfv ; + float-array{ } like glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline + [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence @@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; + [ length ] [ >uint-array ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index eb5bbb0ee8..a77d29da2f 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; dup gl-program-shaders-length 0 over - [ underlying>> glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 1ca041191e..73e719b806 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,7 +1,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool -specialized-arrays.ushort alien.c-types accessors kernel ; +specialized-arrays.ushort alien.c-types accessors kernel +specialized-arrays.direct.int arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ; ] unit-test [ B{ 210 4 1 } byte-array>ushort-array ] must-fail + +[ { 3 1 3 3 7 } ] [ + int-array{ 3 1 3 3 7 } malloc-byte-array 5 >array +] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 6f77e66cd2..a8ce98888c 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -22,7 +22,7 @@ C-STRUCT: test-struct [ 5/4 ] [ [ 2 "test-struct" malloc-struct-array - dup underlying>> &free drop + dup &free drop 1 2 make-point over set-first 3 4 make-point over set-second 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce @@ -34,6 +34,6 @@ C-STRUCT: test-struct [ ] [ [ 10 "test-struct" malloc-struct-array - underlying>> &free drop + &free drop ] with-destructors ] unit-test \ No newline at end of file diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index e2f780cd13..29b137e3de 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -16,5 +16,5 @@ IN: unix.utilities '[ [ advance ] [ *void* _ alien>string ] bi ] [ ] produce nip ; -: strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ; +: strings>alien ( strings encoding -- array ) + '[ _ malloc-string ] void*-array{ } map-as f suffix ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 813d8315ac..c86cde23d9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; + [ execute ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0e9a03f075..314fb167e3 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -59,7 +59,7 @@ SYMBOLS: struct args i alien set-nth ] each-index - alien underlying>> + alien ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index d3fe0a8447..8375636a72 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] int-array{ } map-as underlying>> + } [ x-atom ] int-array{ } map-as 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e0b786ce7d..11473d6e83 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_RGBA , GLX_DEPTH_SIZE , 16 , 0 , - ] int-array{ } make underlying>> + ] int-array{ } make glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 856420af0f..534e47ac37 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -50,7 +50,7 @@ SYMBOL: keysym : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get underlying>> buf-size keysym get 0 + swap keybuf get buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; From 242638fc5c20a70cd96a3dd770ed097fb3327824 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:31 -0600 Subject: [PATCH 034/170] alien.complex vocabulary implementing support for C99 complex numbers --- basis/alien/complex/authors.txt | 1 + basis/alien/complex/complex-tests.factor | 18 ++++++++++ basis/alien/complex/complex.factor | 6 ++++ basis/alien/complex/functor/authors.txt | 1 + .../complex/functor/functor-tests.factor | 4 +++ basis/alien/complex/functor/functor.factor | 35 +++++++++++++++++++ basis/alien/complex/summary.txt | 1 + 7 files changed, 66 insertions(+) create mode 100644 basis/alien/complex/authors.txt create mode 100644 basis/alien/complex/complex-tests.factor create mode 100644 basis/alien/complex/complex.factor create mode 100644 basis/alien/complex/functor/authors.txt create mode 100644 basis/alien/complex/functor/functor-tests.factor create mode 100644 basis/alien/complex/functor/functor.factor create mode 100644 basis/alien/complex/summary.txt diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor new file mode 100644 index 0000000000..bfb2c1137c --- /dev/null +++ b/basis/alien/complex/complex-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex kernel alien.c-types alien.syntax +namespaces ; +IN: alien.complex.tests + +C-STRUCT: complex-holder + { "complex-float" "z" } ; + +: ( z -- alien ) + "complex-holder" + [ set-complex-holder-z ] keep ; + +[ ] [ + C{ 1.0 2.0 } "h" set +] unit-test + +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor new file mode 100644 index 0000000000..60a84b9394 --- /dev/null +++ b/basis/alien/complex/complex.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.complex.functor sequences kernel ; +IN: alien.complex + +<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/functor/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor new file mode 100644 index 0000000000..c2df22be1d --- /dev/null +++ b/basis/alien/complex/functor/functor-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex.functor ; +IN: alien.complex.functor.tests diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor new file mode 100644 index 0000000000..1d12bb0ff4 --- /dev/null +++ b/basis/alien/complex/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.structs alien.c-types math math.functions sequences +arrays kernel functors vocabs.parser namespaces accessors +quotations ; +IN: alien.complex.functor + +FUNCTOR: define-complex-type ( N T -- ) + +T-real DEFINES ${T}-real +T-imaginary DEFINES ${T}-imaginary +set-T-real DEFINES set-${T}-real +set-T-imaginary DEFINES set-${T}-imaginary + +>T DEFINES >${T} +T> DEFINES ${T}> + +WHERE + +: >T ( z -- alien ) + >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + +: T> ( alien -- z ) + [ T-real ] [ T-imaginary ] bi rect> ; inline + +T in get +{ { N "real" } { N "imaginary" } } +define-struct + +T c-type +T> 1quotation >>boxer-quot +>T 1quotation >>unboxer-quot +drop + +;FUNCTOR \ No newline at end of file diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt new file mode 100644 index 0000000000..76c00c1d65 --- /dev/null +++ b/basis/alien/complex/summary.txt @@ -0,0 +1 @@ +Implementation details for C99 complex float and complex double types From 3166828f755bb8e2a0a1c0d4e34e880210cda393 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:54 -0600 Subject: [PATCH 035/170] Fix bug reported by Doug: smart combinators and inline words didn't mix very well in some cases --- basis/combinators/smart/smart-tests.factor | 8 ++++ .../transforms/transforms-tests.factor | 15 ++++++ .../transforms/transforms.factor | 46 ++++++------------- 3 files changed, 38 insertions(+), 31 deletions(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 370dc26960..69a3a821e5 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -37,3 +37,11 @@ IN: combinators.smart.tests [ [ { 1 } { 2 } { 3 } ] B{ } append-outputs-as ] unit-test + +! Test nesting +: nested-smart-combo-test ( -- array ) + [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; + +\ nested-smart-combo-test must-infer + +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 8ae30dcd97..2e2dccd6c4 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -42,3 +42,18 @@ C: color [ bad-new-test ] must-infer [ bad-new-test ] must-fail + +! Corner case if macro expansion calls 'infer', found by Doug +DEFER: smart-combo ( quot -- ) + +\ smart-combo [ infer [ ] curry ] 1 define-transform + +[ [ "a" "b" "c" ] smart-combo ] must-infer + +[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer + +: very-smart-combo ( quot -- ) smart-combo ; inline + +[ [ "a" "b" "c" ] very-smart-combo ] must-infer + +[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 808ea6a141..e5c2f05d72 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel words sequences generic math namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic -sets definitions generic.standard slots.private continuations +sets definitions generic.standard slots.private continuations locals stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; @@ -15,48 +15,32 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] if ; -: ((apply-transform)) ( word quot values stack -- ) - rot with-datastack first2 - dup [ - [ - [ drop ] - [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* - ] 2dip - swap infer-quot - ] [ - 3drop give-up-transform - ] if ; inline +:: ((apply-transform)) ( word quot values stack rstate -- ) + rstate recursive-state + [ stack quot with-datastack first ] with-variable + [ + word inlined-dependency depends-on + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot + ] [ word give-up-transform ] if* ; : (apply-transform) ( word quot n -- ) ensure-d dup [ known literal? ] all? [ - dup empty? [ - recursive-state get 1array - ] [ + dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] [ first literal recursion>> ] tri - prefix ] if ((apply-transform)) ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "transform-quot" word-prop ] - [ "transform-n" word-prop ] - tri - (apply-transform) - ] bi ; + [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + (apply-transform) ; : apply-macro ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "macro" word-prop ] - [ "declared-effect" word-prop in>> length ] - tri - (apply-transform) - ] bi ; + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + (apply-transform) ; : define-transform ( word quot n -- ) [ drop "transform-quot" set-word-prop ] From f9bc9a31981a415c5d26cdf01b529fa1fa5ef4c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:53:08 -0600 Subject: [PATCH 036/170] Fix VM compile error --- vm/math.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/math.c b/vm/math.c index f0aa874886..7bff0de387 100644 --- a/vm/math.c +++ b/vm/math.c @@ -530,8 +530,8 @@ void box_double(double flo) void primitive_from_rect(void) { - F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - complex->imaginary = dpop(); - complex->real = dpop(); - dpush(RETAG(complex,COMPLEX_TYPE)); + F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); + z->imaginary = dpop(); + z->real = dpop(); + dpush(RETAG(z,COMPLEX_TYPE)); } From 5579de1722a1490a45a6e069069aafd5420fdac0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 05:09:10 -0600 Subject: [PATCH 037/170] Fix load error in graphics.bitmap tests --- extra/graphics/bitmap/bitmap-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 4998427b22..15e960084a 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -1,4 +1,4 @@ -USING: graphics.bitmap ; +USING: graphics.bitmap graphics.viewer ; IN: graphics.bitmap.tests : test-bitmap24 ( -- ) From 7e2ac604e718b29bf3e6e8052ac75e22390d92e1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 10:06:22 -0600 Subject: [PATCH 038/170] some initial work on invoking fortran functions --- basis/alien/fortran/fortran-tests.factor | 46 +++++++++++++-- basis/alien/fortran/fortran.factor | 72 ++++++++++++++++++++---- 2 files changed, 103 insertions(+), 15 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 11f0a2efc7..a1f2443b30 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,3 +1,4 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests @@ -11,6 +12,7 @@ F-RECORD: fortran_test_record [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test +[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test ! fortran-type>c-type @@ -57,7 +59,7 @@ F-RECORD: fortran_test_record [ "real" fortran-type>c-type ] unit-test [ "double" ] -[ "double precision" fortran-type>c-type ] unit-test +[ "double-precision" fortran-type>c-type ] unit-test [ "float" ] [ "real*4" fortran-type>c-type ] unit-test @@ -69,7 +71,7 @@ F-RECORD: fortran_test_record [ "complex" fortran-type>c-type ] unit-test [ "(fortran-double-complex)" ] -[ "double complex" fortran-type>c-type ] unit-test +[ "double-complex" fortran-type>c-type ] unit-test [ "(fortran-complex)" ] [ "complex*8" fortran-type>c-type ] unit-test @@ -118,13 +120,13 @@ F-RECORD: fortran_test_record [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] -[ "double precision" fortran-ret-type>c-type ] unit-test +[ "double-precision" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-complex)*" } ] [ "complex" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-double-complex)*" } ] -[ "double complex" fortran-ret-type>c-type ] unit-test +[ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] [ "integer(*)" fortran-ret-type>c-type ] unit-test @@ -155,7 +157,7 @@ unit-test { "char[20]" "woo" } } ] [ { - { "DOUBLE PRECISION" "EX" } + { "DOUBLE-PRECISION" "EX" } { "REAL" "WYE" } { "INTEGER" "ZEE" } { "CHARACTER(20)" "WOO" } @@ -169,3 +171,37 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +! fortran-arg>c-args + +[ B{ 128 } { } ] +[ 128 "integer*1" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? +[ 128 "integer*2" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? +[ 128 "integer*4" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? +[ 128 "integer*8" fortran-arg>c-args ] unit-test + +[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] +[ "hello" "character*5" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? +[ 1.0 "real" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? +[ 1.0 "double-precision" fortran-arg>c-args ] unit-test + +little-endian? +[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] +[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test + +[ B{ 1 0 0 0 2 0 0 0 } { } ] +[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 327db12909..faec9b5b86 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,6 +1,7 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser ; +namespaces parser sequences splitting vectors vocabs.parser locals ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -43,9 +44,9 @@ CONSTANT: fortran>c-types H{ { "integer" integer-type } { "logical" logical-type } { "real" real-type } - { "double precision" double-precision-type } + { "double-precision" double-precision-type } { "complex" real-complex-type } - { "double complex" double-complex-type } + { "double-complex" double-complex-type } } : append-dimensions ( base-c-type type -- c-type ) @@ -82,7 +83,7 @@ M: real-type (fortran-type>c-type) { 4 [ "float" ] } { 8 [ "double" ] } } size-case-type ; -M: complex-type (fortran-type>c-type) +M: real-complex-type (fortran-type>c-type) { { f [ "(fortran-complex)" ] } { 8 [ "(fortran-complex)" ] } @@ -127,12 +128,6 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; -GENERIC: added-c-arg-values ( type -- arg-values ) - -M: fortran-type added-c-arg-values drop { } ; -M: character-type added-c-arg-values - fix-character-type dims>> first 1array ; - GENERIC: returns-by-value? ( type -- ? ) M: fortran-type returns-by-value? drop f ; @@ -147,6 +142,56 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline +: ( complex -- byte-array ) + "(fortran-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +: ( complex -- byte-array ) + "(fortran-double-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) + +M: integer-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -178,6 +223,13 @@ PRIVATE> [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; : F-RECORD: scan in get parse-definition define-record ; parsing + +:: define-fortran-function ( return library function parameters -- ) + ; + +: F-SUBROUTINE: + + ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing From 33b513fb0538ce9946d861f2b853095a54b0cef0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:16:51 -0600 Subject: [PATCH 039/170] byte-length on f outputs 0 --- basis/alien/c-types/c-types.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ff9d4cefc4..cf5daa1562 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -178,6 +178,8 @@ GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; +M: f byte-length drop 0 ; + : c-getter ( name -- quot ) c-type-getter [ [ "Cannot read struct fields with this type" throw ] From 79bb003e6dce8d346032de749f26c791e5be56a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:17:20 -0600 Subject: [PATCH 040/170] io.sockets.secure.openssl: Don't allocate empty password string. Fixes test failures introduced by >c-ptr change --- basis/io/sockets/secure/openssl/openssl.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 0326969e4f..f78f61ef3b 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ push ] [ drop ] 2bi ; : set-default-password ( ctx -- ) - [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] - [ - [ handle>> ] [ default-pasword ] bi - SSL_CTX_set_default_passwd_cb_userdata - ] bi ; + dup config>> password>> [ + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi + ] [ drop ] if ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ From 53758074a29aa3b5c85ede92199705ee11db2433 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:21:55 -0600 Subject: [PATCH 041/170] stack-checker: do constant folding for curry and compose with constant inputs at compile time. Allows macros to expand in more cases, fixing the fry caveat found by Doug --- .../known-words/known-words.factor | 53 ++++++++----------- basis/stack-checker/stack-checker-docs.factor | 8 --- .../stack-checker/stack-checker-tests.factor | 5 ++ .../transforms/transforms-docs.factor | 13 +++-- .../transforms/transforms-tests.factor | 9 ++++ .../transforms/transforms.factor | 4 +- basis/stack-checker/values/values.factor | 30 +++++++++-- 7 files changed, 73 insertions(+), 49 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7cdce301b5..56aebb20e7 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -89,44 +89,37 @@ M: composed infer-call* M: object infer-call* \ literal-expected inference-warning ; -: infer-slip ( -- ) - 1 infer->r infer-call 1 infer-r> ; +: infer-nslip ( n -- ) + [ infer->r infer-call ] [ infer-r> ] bi ; -: infer-2slip ( -- ) - 2 infer->r infer-call 2 infer-r> ; +: infer-slip ( -- ) 1 infer-nslip ; -: infer-3slip ( -- ) - 3 infer->r infer-call 3 infer-r> ; +: infer-2slip ( -- ) 2 infer-nslip ; -: infer-dip ( -- ) - literals get - [ \ dip def>> infer-quot-here ] - [ pop 1 infer->r infer-quot-here 1 infer-r> ] +: infer-3slip ( -- ) 3 infer-nslip ; + +: infer-ndip ( word n -- ) + [ literals get ] 2dip + [ '[ _ def>> infer-quot-here ] ] + [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi* if-empty ; -: infer-2dip ( -- ) - literals get - [ \ 2dip def>> infer-quot-here ] - [ pop 2 infer->r infer-quot-here 2 infer-r> ] - if-empty ; +: infer-dip ( -- ) \ dip 1 infer-ndip ; -: infer-3dip ( -- ) - literals get - [ \ 3dip def>> infer-quot-here ] - [ pop 3 infer->r infer-quot-here 3 infer-r> ] - if-empty ; +: infer-2dip ( -- ) \ 2dip 2 infer-ndip ; -: infer-curry ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ curry #call, ; +: infer-3dip ( -- ) \ 3dip 3 infer-ndip ; -: infer-compose ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ compose #call, ; +: infer-builder ( quot word -- ) + [ + [ 2 consume-d ] dip + [ dup first2 ] dip call make-known + [ push-d ] [ 1array ] bi + ] dip #call, ; inline + +: infer-curry ( -- ) [ ] \ curry infer-builder ; + +: infer-compose ( -- ) [ ] \ compose infer-builder ; : infer-execute ( -- ) pop-literal nip diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5b67cd9adc..5926f08d8c 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -80,13 +80,6 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "compiler-transforms" "Compiler transforms" -"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time." -{ $subsection define-transform } -"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "." -$nl -"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; - ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl @@ -103,7 +96,6 @@ $nl { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } { $subsection "inference-errors" } -{ $subsection "compiler-transforms" } { $see-also "effects" } ; ABOUT: "inference" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 4d7295042c..bc6eb9f092 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -577,3 +577,8 @@ DEFER: eee' [ bogus-error ] must-infer [ [ clear ] infer. ] [ inference-error? ] must-fail-with + +: debugging-curry-folding ( quot -- ) + [ debugging-curry-folding ] curry call ; inline recursive + +[ [ ] debugging-curry-folding ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor index a178669595..de0edc4528 100644 --- a/basis/stack-checker/transforms/transforms-docs.factor +++ b/basis/stack-checker/transforms/transforms-docs.factor @@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ; HELP: define-transform { $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } } -{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." } -{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:" -{ $code ": ndrop ( n -- ) [ drop ] times ;" } -"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:" -{ $code "\\ ndrop [ \\ drop >quotation ] 1 define-transform" } -"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "." +{ $description "Defines a compiler transform for the optimizing compiler." + "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "." $nl -"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" +"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect." +$nl +"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." } +{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $code "\\ cond [ cond>quot ] 1 define-transform" } } ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 2e2dccd6c4..fe580084c0 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- ) [ [ "a" "b" "c" ] very-smart-combo ] must-infer [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer + +! Caveat found by Doug +DEFER: curry-folding-test ( quot -- ) + +\ curry-folding-test [ length \ drop >quotation ] 1 define-transform + +{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as +{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index e5c2f05d72..a2f616480a 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -24,8 +24,10 @@ IN: stack-checker.transforms rstate infer-quot ] [ word give-up-transform ] if* ; +: literals? ( values -- ? ) [ literal-value? ] all? ; + : (apply-transform) ( word quot n -- ) - ensure-d dup [ known literal? ] all? [ + ensure-d dup literals? [ dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 97aa774e55..19db441381 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -26,27 +26,51 @@ SYMBOL: known-values : copy-values ( values -- values' ) [ copy-value ] map ; +GENERIC: (literal-value?) ( value -- ? ) + +M: object (literal-value?) drop f ; + +GENERIC: (literal) ( value -- literal ) + ! Literal value TUPLE: literal < identity-tuple value recursion hashcode ; +: literal ( value -- literal ) known (literal) ; + +: literal-value? ( value -- ? ) known (literal-value?) ; + M: literal hashcode* nip hashcode>> ; : ( obj -- value ) recursive-state get over hashcode \ literal boa ; -GENERIC: (literal) ( value -- literal ) +M: literal (literal-value?) drop t ; M: literal (literal) ; -: literal ( value -- literal ) - known (literal) ; +: curried/composed-literal ( input1 input2 quot -- literal ) + [ [ literal ] bi@ ] dip + [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi + over hashcode \ literal boa ; inline ! Result of curry TUPLE: curried obj quot ; C: curried +: >curried< ( curried -- obj quot ) + [ obj>> ] [ quot>> ] bi ; inline + +M: curried (literal-value?) >curried< [ literal-value? ] both? ; +M: curried (literal) >curried< [ curry ] curried/composed-literal ; + ! Result of compose TUPLE: composed quot1 quot2 ; C: composed + +: >composed< ( composed -- quot1 quot2 ) + [ quot1>> ] [ quot2>> ] bi ; inline + +M: composed (literal-value?) >composed< [ literal-value? ] both? ; +M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file From d1486589efc44be2c58277597dc37e84f70c4017 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:22:09 -0600 Subject: [PATCH 042/170] Improving macro docs --- basis/macros/macros-docs.factor | 45 ++++++++++++++++++++++++++------- basis/macros/macros.factor | 4 +++ core/kernel/kernel-docs.factor | 17 +++++++------ 3 files changed, 49 insertions(+), 17 deletions(-) diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 704cae459a..acd2c3383f 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -1,27 +1,54 @@ -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel +stack-checker.transforms sequences ; IN: macros HELP: MACRO: { $syntax "MACRO: word ( inputs... -- ) definition... ;" } -{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "." -$nl -"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect." -} +{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." } { $notes - "Semantically, the following two definitions are equivalent:" + "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:" + { $list + { "All inputs to the macro call are literal" } + { "The word calling the macro has a static stack effect" } + { "The expansion quotation produced by the macro has a static stack effect" } + } + "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time." + $nl + "Other than possible compile-time expansion, the following two definition styles are equivalent:" { $code "MACRO: foo ... ;" } { $code ": foo ... call ;" } - "However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost." + "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation." +} +{ $examples + "A macro that calls a quotation but preserves any values it consumes off the stack:" + { $code + "USING: fry generalizations ;" + "MACRO: preserving ( quot -- )" + " [ infer in>> length ] keep '[ _ ndup @ ] ;" + } + "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:" + { $code + ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline" + } + "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand." + $nl + "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language." } ; HELP: macro { $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ; ARTICLE: "macros" "Macros" -"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances." +$nl +"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +$nl +"Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" { $subsection POSTPONE: MACRO: } -"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; +"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." +{ $subsection define-transform } +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; ABOUT: "macros" diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 1481e6eea5..4fba7efba3 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; IN: macros +> 1 ; +PRIVATE> + : define-macro ( word definition -- ) [ "macro" set-word-prop ] [ over real-macro-effect memoize-quot [ call ] append define ] diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d85a51edff..71183093ee 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } ; + ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } { $subsection "words" } @@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -$nl -"Data flow combinators:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -"Control flow combinators:" +{ $subsection "dataflow-combinators" } { $subsection "conditionals" } { $subsection "looping-combinators" } -"Additional combinators:" { $subsection "compositional-combinators" } { $subsection "combinators" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." @@ -973,6 +973,7 @@ $nl "Advanced topics:" { $subsection "assertions" } { $subsection "implementing-combinators" } +{ $subsection "macros" } { $subsection "errors" } { $subsection "continuations" } ; From 31f976e0e909aff88f122cde1de0e7bb381969fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:22:22 -0600 Subject: [PATCH 043/170] pack: cleanup, write macros in more intuitive style that works now --- basis/pack/pack.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index aec4414c71..3cf7dbab4c 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -113,9 +113,7 @@ CONSTANT: packed-length-table MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as - '[ _ spread ] - '[ _ input @@ -143,7 +141,7 @@ MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map - '[ _ cleave ] '[ _ output>array ] ; + '[ [ _ cleave ] output>array ] ; PRIVATE> From b206c5a2d1cbe95a99a37c8e961422c97b1d0b11 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 6 Feb 2009 10:54:13 -0600 Subject: [PATCH 044/170] Finishing getting rid of html.elements from basis --- basis/furnace/chloe-tags/chloe-tags.factor | 76 +++++++++---------- basis/furnace/utilities/utilities.factor | 2 +- basis/html/components/components.factor | 7 +- {basis => extra}/html/elements/authors.txt | 0 .../html/elements/elements-docs.factor | 0 .../html/elements/elements-tests.factor | 0 .../html/elements/elements.factor | 0 {basis => extra}/html/elements/summary.txt | 0 {basis => extra}/html/elements/tags.txt | 0 9 files changed, 43 insertions(+), 42 deletions(-) rename {basis => extra}/html/elements/authors.txt (100%) rename {basis => extra}/html/elements/elements-docs.factor (100%) rename {basis => extra}/html/elements/elements-tests.factor (100%) rename {basis => extra}/html/elements/elements.factor (100%) rename {basis => extra}/html/elements/summary.txt (100%) rename {basis => extra}/html/elements/tags.txt (100%) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 2be19c00c3..2bdaacdcba 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -10,7 +10,6 @@ xml.writer xml.traversal xml.syntax html.components -html.elements html.forms html.templates html.templates.chloe @@ -58,14 +57,6 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; #! Side-effects current namespace. '[ [ [ _ ] dip link-attr ] each-responder ] [code] ; -: a-start-tag ( tag -- ) - [ > non-chloe-attrs-only compile-attrs ] - [ compile-link-attrs ] - [ compile-a-url ] - tri - [ =href a> ] [code] ; - : process-attrs ( assoc -- newassoc ) [ "@" ?head [ value present ] when ] assoc-map ; @@ -76,54 +67,61 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; [ non-chloe-attrs ] [ compile-link-attrs ] [ compile-a-url ] tri - [ swap "href" swap set-at ] [code] ; + [ present swap "href" swap [ set-at ] keep ] [code] ; CHLOE: a - [ a-attrs ] - [ compile-children>string ] bi - [ [XML <-> XML] swap >>attrs ] - [xml-code] ; + [ + [ a-attrs ] + [ compile-children>string ] bi + [ [XML <-> XML] second swap >>attrs ] + [xml-code] + ] compile-with-scope ; CHLOE: base compile-a-url [ [XML /> XML] ] [xml-code] ; +USE: io.streams.string + : compile-hidden-form-fields ( for -- ) '[ -
+ [ _ [ "," split [ hidden render ] each ] when* nested-forms get " " join f like nested-forms-key hidden-form-field [ modify-form ] each-responder -
+ ] with-string-writer + [XML
<->
XML] ] [code] ; -: compile-form-attrs ( method action attrs -- ) - [
] [code] ; +: (compile-form-attrs) ( method action -- ) + ! Leaves an assoc on the stack at runtime + [ compile-attr [ "method" pick set-at ] [code] ] + [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ] + bi* ; -: form-start-tag ( tag -- ) - [ - [ "method" optional-attr "post" or ] - [ "action" required-attr ] - [ attrs>> non-chloe-attrs-only ] tri - compile-form-attrs - ] - [ "for" optional-attr compile-hidden-form-fields ] bi ; +: compile-method/action ( tag -- ) + ! generated code is ( assoc -- assoc ) + [ "method" optional-attr "post" or ] + [ "action" required-attr ] bi + (compile-form-attrs) ; -: form-end-tag ( tag -- ) - drop [
] [code] ; +: compile-form-attrs ( tag -- ) + [ non-chloe-attrs ] + [ compile-link-attrs ] + [ compile-method/action ] tri ; + +: hidden-fields ( tag -- ) + "for" optional-attr compile-hidden-form-fields ; CHLOE: form [ - { - [ compile-link-attrs ] - [ form-start-tag ] - [ compile-children ] - [ form-end-tag ] - } cleave + [ compile-form-attrs ] + [ hidden-fields ] + [ compile-children>string ] tri + [ + [XML
<-><->
XML] second + swap >>attrs + write-xml + ] [code] ] compile-with-scope ; : button-tag-markup ( -- xml ) diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 4a9f71e8a9..716e708303 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make assocs sequences kernel classes splitting words vocabs.loader accessors strings combinators arrays -continuations present fry urls http http.server xml.literals xml.writer +continuations present fry urls http http.server xml.syntax xml.writer http.server.redirection http.server.remapping ; IN: furnace.utilities diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 82bb75015e..2b18e28351 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -11,7 +11,7 @@ IN: html.components GENERIC: render* ( value name renderer -- xml ) -: render ( name renderer -- ) +: render>xml ( name renderer -- xml ) prepare-value [ dup validation-error? @@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml ) if ] 2dip render* - swap 2array write-xml ; + swap 2array ; + +: render ( name renderer -- ) + render>xml write-xml ; SINGLETON: label diff --git a/basis/html/elements/authors.txt b/extra/html/elements/authors.txt similarity index 100% rename from basis/html/elements/authors.txt rename to extra/html/elements/authors.txt diff --git a/basis/html/elements/elements-docs.factor b/extra/html/elements/elements-docs.factor similarity index 100% rename from basis/html/elements/elements-docs.factor rename to extra/html/elements/elements-docs.factor diff --git a/basis/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor similarity index 100% rename from basis/html/elements/elements-tests.factor rename to extra/html/elements/elements-tests.factor diff --git a/basis/html/elements/elements.factor b/extra/html/elements/elements.factor similarity index 100% rename from basis/html/elements/elements.factor rename to extra/html/elements/elements.factor diff --git a/basis/html/elements/summary.txt b/extra/html/elements/summary.txt similarity index 100% rename from basis/html/elements/summary.txt rename to extra/html/elements/summary.txt diff --git a/basis/html/elements/tags.txt b/extra/html/elements/tags.txt similarity index 100% rename from basis/html/elements/tags.txt rename to extra/html/elements/tags.txt From 05632b85254fe0bc5968ae934d3629049a2f7f78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 11:03:52 -0600 Subject: [PATCH 045/170] Don't use complex.h since *BSDs don't have it in latest release versions (gah!); add DLLEXPORT for ffi_test_45 to make it work on Windows --- vm/ffi_test.c | 2 +- vm/ffi_test.h | 2 +- vm/master.h | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 36147795d1..c7a9f7d890 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -303,7 +303,7 @@ struct test_struct_14 ffi_test_44(void) return retval; } -complex float ffi_test_45(complex float x, complex double y) +_Complex float ffi_test_45(_Complex float x, _Complex double y) { return x + 2 * y; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index de48d6dc5b..42ab8d71d1 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -89,4 +89,4 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); -complex float ffi_test_45(complex float x, complex double y); +DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y); diff --git a/vm/master.h b/vm/master.h index 01b2335841..86b5223eaa 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,7 +8,6 @@ #include #include #include -#include #include #include From 47a751ad6cb3c9e695e9deb27873f1447b1431ee Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 6 Feb 2009 11:44:58 -0600 Subject: [PATCH 046/170] Slight cleanup and fixing unit test --- basis/furnace/chloe-tags/chloe-tags.factor | 13 +++++-------- basis/furnace/utilities/utilities.factor | 8 +++++--- basis/html/templates/chloe/chloe-tests.factor | 2 +- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 2bdaacdcba..d7d9ae9ebb 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -19,6 +19,7 @@ http http.server http.server.redirection http.server.responses +io.streams.string furnace.utilities ; IN: furnace.chloe-tags @@ -80,16 +81,12 @@ CHLOE: a CHLOE: base compile-a-url [ [XML /> XML] ] [xml-code] ; -USE: io.streams.string - : compile-hidden-form-fields ( for -- ) '[ - [ - _ [ "," split [ hidden render ] each ] when* - nested-forms get " " join f like nested-forms-key hidden-form-field - [ modify-form ] each-responder - ] with-string-writer - [XML
<->
XML] + _ [ "," split [ hidden render>xml ] map ] [ f ] if* + nested-forms get " " join f like nested-forms-key hidden-form-field>xml + [ [ modify-form ] each-responder ] with-string-writer + [XML
<-><-><->
XML] ] [code] ; : (compile-form-attrs) ( method action -- ) diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 716e708303..a2d4c4d996 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -81,11 +81,13 @@ GENERIC: modify-form ( responder -- ) M: object modify-form drop ; -: hidden-form-field ( value name -- ) +: hidden-form-field>xml ( value name -- xml ) over [ [XML name=<->/> XML] - write-xml - ] [ 2drop ] if ; + ] [ drop ] if ; + +: hidden-form-field ( value name -- ) + hidden-form-field>xml write-xml ; : nested-forms-key "__n" ; diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 184f57051a..4e454dcee4 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -135,7 +135,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template From 173b0ee78d7c659f9205dfee80fca8d8d91ea0b4 Mon Sep 17 00:00:00 2001 From: sheeple Date: Fri, 6 Feb 2009 12:21:53 -0600 Subject: [PATCH 047/170] Add some more tests for complex numbers in FFI --- basis/compiler/tests/alien.factor | 14 +++++++++++--- vm/ffi_test.c | 12 +++++++++++- vm/ffi_test.h | 6 +++++- 3 files changed, 27 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b9c62f1429..8830c59b31 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -559,9 +559,17 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline [ ] [ stack-frame-bustage 2drop ] unit-test -FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ; +FUNCTION: complex-float ffi_test_45 ( int x ) ; + +[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test + +FUNCTION: complex-double ffi_test_46 ( int x ) ; + +[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test + +FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; [ C{ 4.0 4.0 } ] [ C{ 1.0 2.0 } - C{ 1.5 1.0 } ffi_test_45 -] unit-test \ No newline at end of file + C{ 1.5 1.0 } ffi_test_47 +] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index c7a9f7d890..a5a43cf2ae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -303,7 +303,17 @@ struct test_struct_14 ffi_test_44(void) return retval; } -_Complex float ffi_test_45(_Complex float x, _Complex double y) +_Complex float ffi_test_45(int x) +{ + return x; +} + +_Complex double ffi_test_46(int x) +{ + return x; +} + +_Complex float ffi_test_47(_Complex float x, _Complex double y) { return x + 2 * y; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 42ab8d71d1..f8634b304e 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -89,4 +89,8 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); -DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y); +DLLEXPORT _Complex float ffi_test_45(int x); + +DLLEXPORT _Complex double ffi_test_46(int x); + +DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); From 01c2e26dfecbd015cdfb6226d0e0efb03f950019 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 12:30:11 -0600 Subject: [PATCH 048/170] Fix alien tests, oops --- basis/compiler/tests/alien.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 8830c59b31..f3c2deb2d8 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -561,11 +561,11 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline FUNCTION: complex-float ffi_test_45 ( int x ) ; -[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test +[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test FUNCTION: complex-double ffi_test_46 ( int x ) ; -[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test +[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; From 01f6c5a7f646ddd2fb2d969876b83c6b2ef29d2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:40:14 -0600 Subject: [PATCH 049/170] add a test for saving bitmaps, refactor load-bitmap a bit --- extra/graphics/bitmap/bitmap-tests.factor | 30 ++++++++++++++++------- extra/graphics/bitmap/bitmap.factor | 27 ++++++++++++-------- 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 15e960084a..ca8be85e12 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -1,15 +1,27 @@ -USING: graphics.bitmap graphics.viewer ; +USING: graphics.bitmap graphics.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; IN: graphics.bitmap.tests -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; +: test-bitmap32-alpha ( -- path ) + "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; +: test-bitmap24 ( -- path ) + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; +: test-bitmap8 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; +: test-bitmap4 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; +: test-bitmap1 ( -- path ) + "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index bd34a9ee41..a1cf37c8a1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - -USING: alien arrays byte-arrays combinators summary -io io.binary io.files kernel libc math -math.functions math.bitwise namespaces opengl opengl.gl -prettyprint sequences strings ui ui.gadgets.panes fry -io.encodings.binary accessors grouping macros alien.c-types ; +USING: accessors alien alien.c-types arrays byte-arrays columns +combinators fry grouping io io.binary io.encodings.binary +io.files kernel libc macros math math.bitwise math.functions +namespaces opengl opengl.gl prettyprint sequences strings +summary ui ui.gadgets.panes ; IN: graphics.bitmap ! Currently can only handle 24/32bit bitmaps. @@ -14,6 +13,7 @@ IN: graphics.bitmap TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index +alpha-channel-zero? array ; : array-copy ( bitmap array -- bitmap array' ) @@ -97,12 +97,19 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap ( path -- bitmap ) +: (load-bitmap) ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader - dup raw-bitmap>array >>array ; + ] with-file-reader ; + +: alpha-channel-zero? ( bitmap -- ? ) + array>> 4 3 [ 0 = ] all? ; + +: load-bitmap ( path -- bitmap ) + (load-bitmap) + dup raw-bitmap>array >>array + dup alpha-channel-zero? >>alpha-channel-zero? ; : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; From 71d176716bcbc310b0e72536eb30082af0be5625 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:53:41 -0600 Subject: [PATCH 050/170] fix 24-game compile error --- extra/24-game/24-game.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 126215ab13..f842d5f4cb 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -15,7 +15,8 @@ SYMBOL: commands { nop rot -rot swap spin swapd } amb-execute ; : makes-24? ( a b c d -- ? ) [ - 2 [ some-rots do-something ] times + some-rots do-something + some-rots do-something maybe-swap do-something 24 = ] @@ -60,4 +61,4 @@ DEFER: check-status : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; : set-commands ( -- ) { + - * / rot swap q } commands set ; : play-game ( -- ) set-commands 24-able repeat ; -MAIN: play-game \ No newline at end of file +MAIN: play-game From 3df4cfb65164bed7ca4b4ec68056c367108fe8bf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:58:17 -0600 Subject: [PATCH 051/170] fix words help-lint --- core/words/words-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 764df9924c..4dfa2d49bc 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -107,7 +107,7 @@ $nl { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "compiler-transforms" } } + { { $snippet "\"infer\"" } { $link "macros" } } { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } From e0e333b449e8e1c2609f127e02c9316683361357 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:13:47 -0600 Subject: [PATCH 052/170] fix link --- basis/html/templates/chloe/chloe-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index b2259e629e..18e6db66f6 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -261,7 +261,7 @@ $nl ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:" { $code "SINGLETON: image" } -"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":" +"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":" { $code "M: image render* 2drop [XML /> XML] ;" } "Finally, we can define a Chloe component:" { $code "COMPONENT: image" } From 89c0dd21ddde9ff339cbd7c7fdbf6420123afba3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:14:03 -0600 Subject: [PATCH 053/170] fix furnace.utilities lint --- basis/furnace/utilities/utilities-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..6defba54d2 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; From 4cd8bba92e3f175e464d1cf2c917244db382e5ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:31:03 -0600 Subject: [PATCH 054/170] better warnings on unsupported bmp formats --- extra/graphics/bitmap/bitmap-tests.factor | 3 +++ extra/graphics/bitmap/bitmap.factor | 12 +++++------- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index ca8be85e12..f8a125e855 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -8,6 +8,9 @@ IN: graphics.bitmap.tests : test-bitmap24 ( -- path ) "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; +: test-bitmap16 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; + : test-bitmap8 ( -- path ) "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index a1cf37c8a1..f8008dc7c1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -39,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; -: 4bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; +ERROR: bmp-not-supported n ; : raw-bitmap>array ( bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } { 24 [ color-index>> ] } - { 16 [ "16bit" throw ] } + { 16 [ bmp-not-supported ] } { 8 [ 8bit>array ] } - { 4 [ 4bit>array ] } - { 2 [ "2bit" throw ] } - { 1 [ "1bit" throw ] } + { 4 [ bmp-not-supported ] } + { 2 [ bmp-not-supported ] } + { 1 [ bmp-not-supported ] } } case >byte-array ; ERROR: bitmap-magic ; From 43a91efde99941c89f5737ca2d17812fa4739e34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:22:28 -0600 Subject: [PATCH 055/170] rename err_no to errno, clear_err_no to clear-errno, move them to libc, update usages --- basis/io/backend/unix/unix.factor | 12 ++++++------ basis/io/sockets/secure/unix/unix.factor | 2 +- basis/io/sockets/unix/unix.factor | 14 +++++++------- basis/libc/libc.factor | 12 ++++++++++-- basis/unix/unix.factor | 9 ++------- 5 files changed, 26 insertions(+), 23 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4bc8868a3c..d86a72c665 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -84,8 +84,8 @@ M: fd refill fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +input+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +input+ ] } [ (io-error) ] } cond ; @@ -104,8 +104,8 @@ M: fd drain over buffer>> buffer-consume buffer>> buffer-empty? f +output+ ? ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +output+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +output+ ] } [ (io-error) ] } cond ; @@ -143,7 +143,7 @@ M: stdin dispose* stdin data>> handle-fd buffer buffer-end size read dup 0 < [ drop - err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if + errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if ] [ size = [ "Error reading stdin pipe" throw ] unless size buffer n>buffer @@ -177,7 +177,7 @@ TUPLE: mx-port < port mx ; : multiplexer-error ( n -- n ) dup 0 < [ - err_no [ EAGAIN = ] [ EINTR = ] bi or + errno [ EAGAIN = ] [ EINTR = ] bi or [ drop 0 ] [ (io-error) ] if ] when ; diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8419246eb6..f1f39a0559 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ; ERR_get_error dup zero? [ drop { - { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] } + { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] } { 0 [ premature-close ] } } case ] [ nip (ssl-error) ] if ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index f209df5862..e701874afd 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr ) dup handle>> handle-fd f 0 write { { [ 0 = ] [ drop ] } - { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } - { [ err_no EINTR = ] [ wait-to-connect ] } + { [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ errno EINTR = ] [ wait-to-connect ] } [ (io-error) ] } cond ; @@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- ) [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi { { [ 0 = ] [ drop ] } - { [ err_no EINPROGRESS = ] [ + { [ errno EINPROGRESS = ] [ [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } [ (io-error) ] @@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr ) 2dup do-accept { { [ over 0 >= ] [ [ 2nip init-fd ] dip ] } - { [ err_no EINTR = ] [ 2drop (accept) ] } - { [ err_no EAGAIN = ] [ + { [ errno EINTR = ] [ 2drop (accept) ] } + { [ errno EAGAIN = ] [ 2drop [ drop +input+ wait-for-port ] [ (accept) ] @@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr ) :: do-send ( packet sockaddr len socket datagram -- ) socket handle-fd packet dup length 0 sockaddr len sendto 0 < [ - err_no EINTR = [ + errno EINTR = [ packet sockaddr len socket datagram do-send ] [ - err_no EAGAIN = [ + errno EAGAIN = [ datagram +output+ wait-for-port packet sockaddr len socket datagram do-send ] [ diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 1e751833a2..bcfb97750f 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,10 +2,18 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations destructors kernel -namespaces accessors sets summary ; +USING: alien alien.syntax assocs continuations destructors +kernel namespaces accessors sets summary ; IN: libc +LIBRARY: factor + +: errno ( -- int ) + "int" "factor" "err_no" { } alien-invoke ; + +: clear-errno ( -- ) + "void" "factor" "clear_err_no" { } alien-invoke ; + Date: Fri, 6 Feb 2009 18:36:00 -0600 Subject: [PATCH 056/170] unbreak bootstrap --- basis/libc/libc.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index bcfb97750f..c154544f81 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,12 +2,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax assocs continuations destructors +USING: alien assocs continuations destructors kernel namespaces accessors sets summary ; IN: libc -LIBRARY: factor - : errno ( -- int ) "int" "factor" "err_no" { } alien-invoke ; From c8c427ec159b92acf5924e757b5ea3ed95d2e692 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:38:41 -0600 Subject: [PATCH 057/170] initial, non-stream-based zlib binding --- basis/zlib/authors.txt | 1 + basis/zlib/ffi/authors.txt | 1 + basis/zlib/ffi/ffi.factor | 30 ++++++++++++++++++++++ basis/zlib/zlib-tests.factor | 9 +++++++ basis/zlib/zlib.factor | 50 ++++++++++++++++++++++++++++++++++++ 5 files changed, 91 insertions(+) create mode 100755 basis/zlib/authors.txt create mode 100755 basis/zlib/ffi/authors.txt create mode 100755 basis/zlib/ffi/ffi.factor create mode 100755 basis/zlib/zlib-tests.factor create mode 100755 basis/zlib/zlib.factor diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..bda2809f56 --- /dev/null +++ b/basis/zlib/ffi/ffi.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.syntax combinators system ; +IN: zlib.ffi + +<< "zlib" { + { [ os winnt? ] [ "zlib1.dll" ] } + { [ os macosx? ] [ "libz.dylib" ] } + { [ os unix? ] [ "libz.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: zlib + +CONSTANT: Z_OK 0 +CONSTANT: Z_STREAM_END 1 +CONSTANT: Z_NEED_DICT 2 +CONSTANT: Z_ERRNO -1 +CONSTANT: Z_STREAM_ERROR -2 +CONSTANT: Z_DATA_ERROR -3 +CONSTANT: Z_MEM_ERROR -4 +CONSTANT: Z_BUF_ERROR -5 +CONSTANT: Z_VERSION_ERROR -6 + +TYPEDEF: void Bytef +TYPEDEF: ulong uLongf +TYPEDEF: ulong uLong + +FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; +FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; +FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor new file mode 100755 index 0000000000..0ac77277dc --- /dev/null +++ b/basis/zlib/zlib-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test zlib classes ; +IN: zlib.tests + +: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; + +[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test +[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor new file mode 100755 index 0000000000..d5eed0b35b --- /dev/null +++ b/basis/zlib/zlib.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax byte-arrays combinators +kernel math math.functions sequences system accessors +libc ; +QUALIFIED: zlib.ffi +IN: zlib + +TUPLE: compressed data length ; + +: ( data length -- compressed ) + compressed new + swap >>length + swap >>data ; + +ERROR: zlib-failed n string ; + +: zlib-error-message ( n -- * ) + dup zlib.ffi:Z_ERRNO = [ + drop errno "native libc error" + ] [ + dup { + "no error" "libc_error" + "stream error" "data error" + "memory error" "buffer error" "zlib version error" + } ?nth + ] if zlib-failed ; + +: zlib-error ( n -- ) + dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; + +! Compressed size is up to .001% larger plus 12 + +: compressed-size ( byte-array -- n ) + length 1001/1000 * ceiling 12 + ; + +: compress ( byte-array -- compressed ) + [ + [ compressed-size dup length ] keep [ + dup length zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + zlib.ffi:uncompress zlib-error + ] bi *ulong head ; From d5dc7f5db51dca61fcb316298e0bc17aa5db38a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:40:41 -0600 Subject: [PATCH 058/170] remove bad comment --- basis/zlib/zlib.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor index d5eed0b35b..b40d9c2a98 100755 --- a/basis/zlib/zlib.factor +++ b/basis/zlib/zlib.factor @@ -29,8 +29,6 @@ ERROR: zlib-failed n string ; : zlib-error ( n -- ) dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; -! Compressed size is up to .001% larger plus 12 - : compressed-size ( byte-array -- n ) length 1001/1000 * ceiling 12 + ; From 201296c04043eeb281a28e1b844ca1ee8f9f0147 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:46:23 -0600 Subject: [PATCH 059/170] dllexport err_no and clear_err_no --- vm/io.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/io.h b/vm/io.h index 08c9dd7807..dc7d69edee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -1,7 +1,7 @@ void init_c_io(void); void io_error(void); -int err_no(void); -void clear_err_no(void); +DLLEXPORT int err_no(void); +DLLEXPORT void clear_err_no(void); void primitive_fopen(void); void primitive_fgetc(void); From 118f2de4667d47a79563b7a3d9c07308781c14b5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 19:05:56 -0600 Subject: [PATCH 060/170] fortran-invoke sketch --- basis/alien/complex/complex-tests.factor | 2 +- basis/alien/complex/functor/functor.factor | 14 +- basis/alien/fortran/fortran-tests.factor | 170 ++++++++++++++------ basis/alien/fortran/fortran.factor | 178 +++++++++++++++------ 4 files changed, 260 insertions(+), 104 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index bfb2c1137c..0bff73b898 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -15,4 +15,4 @@ C-STRUCT: complex-holder C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1d12bb0ff4..c6644eba1d 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary set-T-real DEFINES set-${T}-real set-T-imaginary DEFINES set-${T}-imaginary ->T DEFINES >${T} -T> DEFINES ${T}> + DEFINES <${T}> +*T DEFINES *${T} WHERE -: >T ( z -- alien ) +: ( z -- alien ) >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline -: T> ( alien -- z ) +: *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline T in get @@ -28,8 +28,8 @@ T in get define-struct T c-type -T> 1quotation >>boxer-quot ->T 1quotation >>unboxer-quot + 1quotation >>boxer-quot +*T 1quotation >>unboxer-quot drop -;FUNCTOR \ No newline at end of file +;FUNCTOR diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index a1f2443b30..0a86cba7e3 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,12 +1,13 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel namespaces sequences tools.test ; +alien.syntax arrays assocs kernel macros namespaces sequences +tools.test fry ; IN: alien.fortran.tests -F-RECORD: fortran_test_record - { "integer" "foo" } - { "real" "bar" } - { "character*4" "bas" } ; +RECORD: FORTRAN_TEST_RECORD + { "INTEGER" "FOO" } + { "REAL(2)" "BAR" } + { "CHARACTER*4" "BAS" } ; ! fortran-name>symbol-name @@ -67,19 +68,16 @@ F-RECORD: fortran_test_record [ "double" ] [ "real*8" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "double-complex" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex*8" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] -[ "complex*16" fortran-type>c-type ] unit-test - -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "complex*16" fortran-type>c-type ] unit-test [ "fortran_test_record" ] @@ -122,10 +120,10 @@ F-RECORD: fortran_test_record [ "double" { } ] [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-complex)*" } ] +[ "void" { "complex-float*" } ] [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-double-complex)*" } ] +[ "void" { "complex-double*" } ] [ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] @@ -144,7 +142,7 @@ unit-test [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test -[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test @@ -164,44 +162,126 @@ unit-test } fortran-record>c-struct ] unit-test -! F-RECORD: +! RECORD: -[ 12 ] [ "fortran_test_record" heap-size ] unit-test +[ 16 ] [ "fortran_test_record" heap-size ] unit-test [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test -[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-arg>c-args +! fortran-invoke -[ B{ 128 } { } ] -[ 128 "integer*1" fortran-arg>c-args ] unit-test +: fortran-invoke-expansion ( return library function parameters -- quot ) + '[ _ _ _ _ fortran-invoke ] expand-macros ; inline -little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? -[ 128 "integer*2" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "funtimes_" + { "char*" "int*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + { + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + [ drop ] + } spread +] ] [ + f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? -[ 128 "integer*4" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-invoke] + "double" "foopack" "fun_times__" + { "float*" } + alien-invoke +] ] [ + "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? -[ 128 "integer*8" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + { + [ *complex-float ] + [ drop ] + } spread +] ] [ + "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] -[ "hello" "character*5" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 20 20 ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "float*" } + alien-invoke + ] 3 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ drop ] + } spread +] ] [ + "CHARACTER*20" "foopack" "FUN_TIMES" { } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? -[ 1.0 "real" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? -[ 1.0 "double-precision" fortran-arg>c-args ] unit-test - -little-endian? -[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] -[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test - -[ B{ 1 0 0 0 2 0 0 0 } { } ] -[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 10 10 ] 2 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + } spread ] + [ { [ length ] [ drop ] } spread ] + } 2 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "char*" "float*" "long" } + alien-invoke + ] 5 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ ] + [ *float swap ] + [ ascii alien>nstring ] + } spread +] ] [ + "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } + fortran-invoke-expansion +] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index faec9b5b86..b0bbedd716 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,20 +1,15 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals ; +namespaces parser sequences splitting vectors vocabs.parser locals +io.encodings.ascii io.encodings.string ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes -C-STRUCT: (fortran-complex) - { "float" "r" } - { "float" "i" } ; -C-STRUCT: (fortran-double-complex) - { "double" "r" } - { "double" "i" } ; - -: fortran-c-abi ( -- abi ) "cdecl" ; +: alien>nstring ( alien len encoding -- string ) + [ memory>byte-array ] dip decode ; : fortran-name>symbol-name ( fortran-name -- c-name ) >lower CHAR: _ over member? @@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex) ERROR: invalid-fortran-type type ; +DEFER: fortran-sig>c-sig + > [ invalid-fortran-type ] [ drop ] if ] [ append-dimensions ] bi ; -: new-fortran-type ( dims size class -- type ) - new [ (>>size) ] [ (>>dims) ] [ ] tri ; +: new-fortran-type ( out? dims size class -- type ) + new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ; GENERIC: (fortran-type>c-type) ( type -- c-type ) -M: f (fortran-type>c-type) ; +M: f (fortran-type>c-type) drop "void" ; M: integer-type (fortran-type>c-type) { @@ -85,9 +82,9 @@ M: real-type (fortran-type>c-type) } size-case-type ; M: real-complex-type (fortran-type>c-type) { - { f [ "(fortran-complex)" ] } - { 8 [ "(fortran-complex)" ] } - { 16 [ "(fortran-double-complex)" ] } + { f [ "complex-float" ] } + { 8 [ "complex-float" ] } + { 16 [ "complex-double" ] } } size-case-type ; M: double-precision-type (fortran-type>c-type) @@ -108,6 +105,9 @@ M: character-type (fortran-type>c-type) : dimension>number ( string -- number ) dup "*" = [ drop 0 ] [ string>number ] if ; +: parse-out ( string -- string' out? ) + "!" ?head ; + : parse-dims ( string -- string' dim ) "(" split1 dup [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; @@ -115,10 +115,13 @@ M: character-type (fortran-type>c-type) : parse-size ( string -- string' size ) "*" split1 dup [ string>number ] when ; -: parse-fortran-type ( fortran-type-string -- type ) - parse-dims swap parse-size swap +: (parse-fortran-type) ( fortran-type-string -- type ) + parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop misc-type boa ] if ; + [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + +: parse-fortran-type ( fortran-type-string/f -- type/f ) + dup [ (parse-fortran-type) ] when ; : c-type>pointer ( c-type -- c-type* ) "[" split1 drop "*" append ; @@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ; GENERIC: returns-by-value? ( type -- ? ) +M: f returns-by-value? drop t ; M: fortran-type returns-by-value? drop f ; M: number-type returns-by-value? dims>> not ; M: complex-type returns-by-value? drop f ; GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) +M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline -: ( complex -- byte-array ) - "(fortran-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; +GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) -: ( complex -- byte-array ) - "(fortran-double-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; - -GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) - -M: integer-type [fortran-arg>c-args] +M: integer-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 1 [ [ ] [ drop ] ] } @@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-type [fortran-arg>c-args] +M: logical-type (fortran-arg>c-args) + call-next-method [ [ 1 0 ? ] prepend ] dip ; + +M: real-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 4 [ [ ] [ drop ] ] } @@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: real-complex-type (fortran-arg>c-args) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: double-precision-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: double-complex-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: character-type (fortran-arg>c-args) + drop [ ascii string>alien ] [ length ] ; + +M: misc-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +GENERIC: (fortran-result>) ( type -- quot ) + +M: integer-type (fortran-result>) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ *int ] ] } + { 1 [ [ *char ] ] } + { 2 [ [ *short ] ] } + { 4 [ [ *int ] ] } + { 8 [ [ *longlong ] ] } [ invalid-fortran-type ] } case ; -M: +M: logical-type (fortran-result>) + call-next-method [ zero? not ] append ; + +M: real-type (fortran-result>) + size>> { + { f [ [ *float ] ] } + { 4 [ [ *float ] ] } + { 8 [ [ *double ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type (fortran-result>) + size>> { + { f [ [ *complex-float ] ] } + { 8 [ [ *complex-float ] ] } + { 16 [ [ *complex-double ] ] } + [ invalid-fortran-type ] + } case ; + +M: double-precision-type (fortran-result>) + drop [ *double ] ; + +M: double-complex-type (fortran-result>) + drop [ *complex-double ] ; + +M: character-type (fortran-result>) + drop [ ascii alien>nstring ] ; + +M: misc-type (fortran-result>) + drop [ ] ; + +GENERIC: () ( type -- quot ) + +M: fortran-type () + (fortran-type>c-type) '[ _ ] ; + +: [] ( return parameters -- quot ) + [ parse-fortran-type ] dip + over returns-by-value? + [ 2drop [ ] ] + [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + +: [fortran-args>c-args] ( parameters -- quot ) + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi + '[ _ _ ncleave ] ; + +:: [fortran-invoke] ( return library function parameters -- quot ) + return parameters fortran-sig>c-sig :> c-parameters :> c-return + function fortran-name>symbol-name :> c-function + [ c-return library c-function c-parameters alien-invoke ] ; + +: [fortran-results>] ( return parameters -- quot ) + 2drop [ ] ; PRIVATE> @@ -219,17 +284,28 @@ PRIVATE> : fortran-record>c-struct ( record -- struct ) [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; -: define-record ( name vocab fields -- ) +: define-fortran-record ( name vocab fields -- ) [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; -: F-RECORD: scan in get parse-definition define-record ; parsing +: RECORD: scan in get parse-definition define-fortran-record ; parsing + +MACRO: fortran-invoke ( return library function parameters -- ) + { + [ 2nip [] ] + [ nip nip nip [fortran-args>c-args] ] + [ [fortran-invoke] ] + [ 2nip [fortran-results>] ] + } 4 ncleave 3append ; :: define-fortran-function ( return library function parameters -- ) - ; + function create-in dup reset-generic + return library function parameters return parse-arglist + [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; -: F-SUBROUTINE: - - -! : F-SUBROUTINE: ... ; parsing -! : F-FUNCTION: ... ; parsing +: SUBROUTINE: + f "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing +: FUNCTION: + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing From c45b188581a2bcbff8a4d929e82e307bff66d72f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 22:43:11 -0600 Subject: [PATCH 061/170] fix furnace.utilities --- basis/furnace/utilities/utilities-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index 6defba54d2..3a0d8804ef 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; From 0fc6dde17877ff2ff2194339197b7882e382308e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 22:56:46 -0600 Subject: [PATCH 062/170] make sure multipart parsing has enough bytes to compare against --- basis/mime/multipart/multipart.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index eda7849a73..37d5e13129 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ; [ t >>end-of-stream? ] if* ; : maybe-fill-bytes ( multipart -- multipart ) - dup bytes>> [ fill-bytes ] unless ; + dup bytes>> length 256 < [ fill-bytes ] when ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) dupd [ length ] bi@ 1- - short cut-slice swap ; @@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ; [ dump-until-separator ] with-string-writer ; : read-header ( multipart -- multipart ) + maybe-fill-bytes dup bytes>> "--\r\n" sequence= [ t >>end-of-stream? ] [ From b073fe5eeebb803a4af2ac01f31b9db15dba7cbf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:37:18 -0600 Subject: [PATCH 063/170] the start of an endianness library, used by pack --- basis/endian/authors.txt | 1 + basis/endian/endian-tests.factor | 7 ++++ basis/endian/endian.factor | 67 ++++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+) create mode 100755 basis/endian/authors.txt create mode 100755 basis/endian/endian-tests.factor create mode 100755 basis/endian/endian.factor diff --git a/basis/endian/authors.txt b/basis/endian/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/endian/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/endian/endian-tests.factor b/basis/endian/endian-tests.factor new file mode 100755 index 0000000000..b066ce6995 --- /dev/null +++ b/basis/endian/endian-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces tools.test endian ; +IN: endian.tests + +[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test +[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor new file mode 100755 index 0000000000..a832d6c0a2 --- /dev/null +++ b/basis/endian/endian.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types namespaces io.binary fry +kernel math ; +IN: endian + +SINGLETONS: big-endian little-endian ; + +: native-endianness ( -- class ) + 1 *char 0 = big-endian little-endian ? ; + +: >signed ( x n -- y ) + 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + +native-endianness \ native-endianness set-global + +SYMBOL: endianness + +\ native-endianness get-global endianness set-global + +HOOK: >native-endian native-endianness ( obj n -- str ) + +M: big-endian >native-endian >be ; + +M: little-endian >native-endian >le ; + +HOOK: unsigned-native-endian> native-endianness ( obj -- str ) + +M: big-endian unsigned-native-endian> be> ; + +M: little-endian unsigned-native-endian> le> ; + +: signed-native-endian> ( obj n -- str ) + [ unsigned-native-endian> ] dip >signed ; + +HOOK: >endian endianness ( obj n -- str ) + +M: big-endian >endian >be ; + +M: little-endian >endian >le ; + +HOOK: endian> endianness ( seq -- n ) + +M: big-endian endian> be> ; + +M: little-endian endian> le> ; + +HOOK: unsigned-endian> endianness ( obj -- str ) + +M: big-endian unsigned-endian> be> ; + +M: little-endian unsigned-endian> le> ; + +: signed-endian> ( obj n -- str ) + [ unsigned-endian> ] dip >signed ; + +: with-endianness ( endian quot -- ) + [ endianness ] dip with-variable ; inline + +: with-big-endian ( quot -- ) + big-endian swap with-endianness ; inline + +: with-little-endian ( quot -- ) + little-endian swap with-endianness ; inline + +: with-native-endian ( quot -- ) + \ native-endianness get-global swap with-endianness ; inline From 1979fbc61a1c5edb95b69c3cfd56b6f34fbebff8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:37:38 -0600 Subject: [PATCH 064/170] pack uses endian library now --- basis/pack/pack.factor | 38 +++++++------------------------------- 1 file changed, 7 insertions(+), 31 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 3cf7dbab4c..9078817206 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces make parser prettyprint quotations sequences strings vectors words macros math.functions math.bitwise fry generalizations combinators.smart io.streams.byte-array io.encodings.binary -math.vectors combinators multiline ; +math.vectors combinators multiline endian ; IN: pack -SYMBOL: big-endian - -: big-endian? ( -- ? ) - 1 *char zero? ; - - - -: >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; - -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; inline - -: unsigned-endian> ( obj -- str ) - big-endian get [ be> ] [ le> ] if ; inline - -: signed-endian> ( obj n -- str ) - [ unsigned-endian> ] dip >signed ; - GENERIC: >n-byte-array ( obj n -- byte-array ) M: integer >n-byte-array ( m n -- byte-array ) >endian ; @@ -124,13 +100,13 @@ PRIVATE> [ ch>packed-length ] sigma ; : pack-native ( seq str -- seq ) - [ set-big-endian pack ] with-scope ; inline + '[ _ _ pack ] with-native-endian ; inline : pack-be ( seq str -- seq ) - [ big-endian on pack ] with-scope ; inline + '[ _ _ pack ] with-big-endian ; inline : pack-le ( seq str -- seq ) - [ big-endian off pack ] with-scope ; inline + '[ _ _ pack ] with-little-endian ; inline : unpack-native ( seq str -- seq ) - [ set-big-endian unpack ] with-scope ; inline + '[ _ _ unpack ] with-native-endian ; inline : unpack-be ( seq str -- seq ) - [ big-endian on unpack ] with-scope ; inline + '[ _ _ unpack ] with-big-endian ; inline : unpack-le ( seq str -- seq ) - [ big-endian off unpack ] with-scope ; inline + '[ _ _ unpack ] with-little-endian ; inline ERROR: packed-read-fail str bytes ; From 26f9df982d372c9e628112ba030bca1cd1514ec0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:41:59 -0600 Subject: [PATCH 065/170] the start of a tiff library --- extra/graphics/tiff/authors.txt | 1 + extra/graphics/tiff/rgb.tiff | Bin 0 -> 7916 bytes extra/graphics/tiff/tiff-tests.factor | 9 +++++++ extra/graphics/tiff/tiff.factor | 37 ++++++++++++++++++++++++++ 4 files changed, 47 insertions(+) create mode 100755 extra/graphics/tiff/authors.txt create mode 100755 extra/graphics/tiff/rgb.tiff create mode 100755 extra/graphics/tiff/tiff-tests.factor create mode 100755 extra/graphics/tiff/tiff.factor diff --git a/extra/graphics/tiff/authors.txt b/extra/graphics/tiff/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/graphics/tiff/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/graphics/tiff/rgb.tiff b/extra/graphics/tiff/rgb.tiff new file mode 100755 index 0000000000000000000000000000000000000000..71cbaa9d6e807156f7da39a5b116c9edb3b0c9e1 GIT binary patch literal 7916 zcmeHMcT^MWw+#r=t3X6RRC<#hYUoXR4bnxLK!S7xL9Q1Cgh&@qz)BGldhfkA=^#Z! zK)@iqNqZASuUB2~z4iWmzr{LhhA%Uj$#>4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk literal 0 HcmV?d00001 diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor new file mode 100755 index 0000000000..daee9a5d9e --- /dev/null +++ b/extra/graphics/tiff/tiff-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test graphics.tiff ; +IN: graphics.tiff.tests + +: tiff-test-path ( -- path ) + "resource:extra/graphics/tiff/rgb.tiff" ; + + diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor new file mode 100755 index 0000000000..4676ea2748 --- /dev/null +++ b/extra/graphics/tiff/tiff.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io io.encodings.binary io.files +kernel pack endian ; +IN: graphics.tiff + +TUPLE: tiff +endianness +the-answer +ifd-offset +; + + +ERROR: bad-tiff-magic bytes ; + +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: (load-tiff) ( path -- tiff ) + binary [ + tiff new + read-header + ] with-file-reader ; + +: load-tiff ( path -- tiff ) + (load-tiff) ; From a4b174d04b64df457331dd6e881b4e987d29422f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 00:58:02 -0600 Subject: [PATCH 066/170] spruce up unmaintained/openal -- can maybe go back into extra/ --- unmaintained/openal/macosx/macosx.factor | 6 +- unmaintained/openal/openal.factor | 252 +++++++++++------------ 2 files changed, 128 insertions(+), 130 deletions(-) diff --git a/unmaintained/openal/macosx/macosx.factor b/unmaintained/openal/macosx/macosx.factor index d2a0422d8d..abc0d65fb9 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/unmaintained/openal/macosx/macosx.factor @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; M: macosx load-wav-file ( path -- format data size frequency ) - 0 f 0 0 - [ alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ alutLoadWAVFile ] 4keep + [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/unmaintained/openal/openal.factor b/unmaintained/openal/openal.factor index 40593d1e8d..8533308f26 100644 --- a/unmaintained/openal/openal.factor +++ b/unmaintained/openal/openal.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays alien system combinators alien.syntax namespaces - alien.c-types sequences vocabs.loader shuffle combinators.lib + alien.c-types sequences vocabs.loader shuffle openal.backend specialized-arrays.uint ; IN: openal @@ -36,75 +36,75 @@ TYPEDEF: int ALenum TYPEDEF: float ALfloat TYPEDEF: double ALdouble -: AL_INVALID ( -- number ) -1 ; inline -: AL_NONE ( -- number ) 0 ; inline -: AL_FALSE ( -- number ) 0 ; inline -: AL_TRUE ( -- number ) 1 ; inline -: AL_SOURCE_RELATIVE ( -- number ) HEX: 202 ; inline -: AL_CONE_INNER_ANGLE ( -- nmber ) HEX: 1001 ; inline -: AL_CONE_OUTER_ANGLE ( -- number ) HEX: 1002 ; inline -: AL_PITCH ( -- number ) HEX: 1003 ; inline -: AL_POSITION ( -- number ) HEX: 1004 ; inline -: AL_DIRECTION ( -- number ) HEX: 1005 ; inline -: AL_VELOCITY ( -- number ) HEX: 1006 ; inline -: AL_LOOPING ( -- number ) HEX: 1007 ; inline -: AL_BUFFER ( -- number ) HEX: 1009 ; inline -: AL_GAIN ( -- number ) HEX: 100A ; inline -: AL_MIN_GAIN ( -- number ) HEX: 100D ; inline -: AL_MAX_GAIN ( -- number ) HEX: 100E ; inline -: AL_ORIENTATION ( -- number ) HEX: 100F ; inline -: AL_CHANNEL_MASK ( -- number ) HEX: 3000 ; inline -: AL_SOURCE_STATE ( -- number ) HEX: 1010 ; inline -: AL_INITIAL ( -- number ) HEX: 1011 ; inline -: AL_PLAYING ( -- number ) HEX: 1012 ; inline -: AL_PAUSED ( -- number ) HEX: 1013 ; inline -: AL_STOPPED ( -- number ) HEX: 1014 ; inline -: AL_BUFFERS_QUEUED ( -- number ) HEX: 1015 ; inline -: AL_BUFFERS_PROCESSED ( -- number ) HEX: 1016 ; inline -: AL_SEC_OFFSET ( -- number ) HEX: 1024 ; inline -: AL_SAMPLE_OFFSET ( -- number ) HEX: 1025 ; inline -: AL_BYTE_OFFSET ( -- number ) HEX: 1026 ; inline -: AL_SOURCE_TYPE ( -- number ) HEX: 1027 ; inline -: AL_STATIC ( -- number ) HEX: 1028 ; inline -: AL_STREAMING ( -- number ) HEX: 1029 ; inline -: AL_UNDETERMINED ( -- number ) HEX: 1030 ; inline -: AL_FORMAT_MONO8 ( -- number ) HEX: 1100 ; inline -: AL_FORMAT_MONO16 ( -- number ) HEX: 1101 ; inline -: AL_FORMAT_STEREO8 ( -- number ) HEX: 1102 ; inline -: AL_FORMAT_STEREO16 ( -- number ) HEX: 1103 ; inline -: AL_REFERENCE_DISTANCE ( -- number ) HEX: 1020 ; inline -: AL_ROLLOFF_FACTOR ( -- number ) HEX: 1021 ; inline -: AL_CONE_OUTER_GAIN ( -- number ) HEX: 1022 ; inline -: AL_MAX_DISTANCE ( -- number ) HEX: 1023 ; inline -: AL_FREQUENCY ( -- number ) HEX: 2001 ; inline -: AL_BITS ( -- number ) HEX: 2002 ; inline -: AL_CHANNELS ( -- number ) HEX: 2003 ; inline -: AL_SIZE ( -- number ) HEX: 2004 ; inline -: AL_UNUSED ( -- number ) HEX: 2010 ; inline -: AL_PENDING ( -- number ) HEX: 2011 ; inline -: AL_PROCESSED ( -- number ) HEX: 2012 ; inline -: AL_NO_ERROR ( -- number ) AL_FALSE ; inline -: AL_INVALID_NAME ( -- number ) HEX: A001 ; inline -: AL_ILLEGAL_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_VALUE ( -- number ) HEX: A003 ; inline -: AL_ILLEGAL_COMMAND ( -- number ) HEX: A004 ; inline -: AL_INVALID_OPERATION ( -- number ) HEX: A004 ; inline -: AL_OUT_OF_MEMORY ( -- number ) HEX: A005 ; inline -: AL_VENDOR ( -- number ) HEX: B001 ; inline -: AL_VERSION ( -- number ) HEX: B002 ; inline -: AL_RENDERER ( -- number ) HEX: B003 ; inline -: AL_EXTENSIONS ( -- number ) HEX: B004 ; inline -: AL_DOPPLER_FACTOR ( -- number ) HEX: C000 ; inline -: AL_DOPPLER_VELOCITY ( -- number ) HEX: C001 ; inline -: AL_SPEED_OF_SOUND ( -- number ) HEX: C003 ; inline -: AL_DISTANCE_MODEL ( -- number ) HEX: D000 ; inline -: AL_INVERSE_DISTANCE ( -- number ) HEX: D001 ; inline -: AL_INVERSE_DISTANCE_CLAMPED ( -- number ) HEX: D002 ; inline -: AL_LINEAR_DISTANCE ( -- number ) HEX: D003 ; inline -: AL_LINEAR_DISTANCE_CLAMPED ( -- number ) HEX: D004 ; inline -: AL_EXPONENT_DISTANCE ( -- number ) HEX: D005 ; inline -: AL_EXPONENT_DISTANCE_CLAMPED ( -- number ) HEX: D006 ; inline +CONSTANT: AL_INVALID -1 +CONSTANT: AL_NONE 0 +CONSTANT: AL_FALSE 0 +CONSTANT: AL_TRUE 1 +CONSTANT: AL_SOURCE_RELATIVE HEX: 202 +CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001 +CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002 +CONSTANT: AL_PITCH HEX: 1003 +CONSTANT: AL_POSITION HEX: 1004 +CONSTANT: AL_DIRECTION HEX: 1005 +CONSTANT: AL_VELOCITY HEX: 1006 +CONSTANT: AL_LOOPING HEX: 1007 +CONSTANT: AL_BUFFER HEX: 1009 +CONSTANT: AL_GAIN HEX: 100A +CONSTANT: AL_MIN_GAIN HEX: 100D +CONSTANT: AL_MAX_GAIN HEX: 100E +CONSTANT: AL_ORIENTATION HEX: 100F +CONSTANT: AL_CHANNEL_MASK HEX: 3000 +CONSTANT: AL_SOURCE_STATE HEX: 1010 +CONSTANT: AL_INITIAL HEX: 1011 +CONSTANT: AL_PLAYING HEX: 1012 +CONSTANT: AL_PAUSED HEX: 1013 +CONSTANT: AL_STOPPED HEX: 1014 +CONSTANT: AL_BUFFERS_QUEUED HEX: 1015 +CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016 +CONSTANT: AL_SEC_OFFSET HEX: 1024 +CONSTANT: AL_SAMPLE_OFFSET HEX: 1025 +CONSTANT: AL_BYTE_OFFSET HEX: 1026 +CONSTANT: AL_SOURCE_TYPE HEX: 1027 +CONSTANT: AL_STATIC HEX: 1028 +CONSTANT: AL_STREAMING HEX: 1029 +CONSTANT: AL_UNDETERMINED HEX: 1030 +CONSTANT: AL_FORMAT_MONO8 HEX: 1100 +CONSTANT: AL_FORMAT_MONO16 HEX: 1101 +CONSTANT: AL_FORMAT_STEREO8 HEX: 1102 +CONSTANT: AL_FORMAT_STEREO16 HEX: 1103 +CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020 +CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021 +CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022 +CONSTANT: AL_MAX_DISTANCE HEX: 1023 +CONSTANT: AL_FREQUENCY HEX: 2001 +CONSTANT: AL_BITS HEX: 2002 +CONSTANT: AL_CHANNELS HEX: 2003 +CONSTANT: AL_SIZE HEX: 2004 +CONSTANT: AL_UNUSED HEX: 2010 +CONSTANT: AL_PENDING HEX: 2011 +CONSTANT: AL_PROCESSED HEX: 2012 +CONSTANT: AL_NO_ERROR AL_FALSE +CONSTANT: AL_INVALID_NAME HEX: A001 +CONSTANT: AL_ILLEGAL_ENUM HEX: A002 +CONSTANT: AL_INVALID_ENUM HEX: A002 +CONSTANT: AL_INVALID_VALUE HEX: A003 +CONSTANT: AL_ILLEGAL_COMMAND HEX: A004 +CONSTANT: AL_INVALID_OPERATION HEX: A004 +CONSTANT: AL_OUT_OF_MEMORY HEX: A005 +CONSTANT: AL_VENDOR HEX: B001 +CONSTANT: AL_VERSION HEX: B002 +CONSTANT: AL_RENDERER HEX: B003 +CONSTANT: AL_EXTENSIONS HEX: B004 +CONSTANT: AL_DOPPLER_FACTOR HEX: C000 +CONSTANT: AL_DOPPLER_VELOCITY HEX: C001 +CONSTANT: AL_SPEED_OF_SOUND HEX: C003 +CONSTANT: AL_DISTANCE_MODEL HEX: D000 +CONSTANT: AL_INVERSE_DISTANCE HEX: D001 +CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002 +CONSTANT: AL_LINEAR_DISTANCE HEX: D003 +CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004 +CONSTANT: AL_EXPONENT_DISTANCE HEX: D005 +CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006 FUNCTION: void alEnable ( ALenum capability ) ; FUNCTION: void alDisable ( ALenum capability ) ; @@ -182,34 +182,34 @@ FUNCTION: void alDistanceModel ( ALenum distanceModel ) ; LIBRARY: alut -: ALUT_API_MAJOR_VERSION ( -- number ) 1 ; inline -: ALUT_API_MINOR_VERSION ( -- number ) 1 ; inline -: ALUT_ERROR_NO_ERROR ( -- number ) 0 ; inline -: ALUT_ERROR_OUT_OF_MEMORY ( -- number ) HEX: 200 ; inline -: ALUT_ERROR_INVALID_ENUM ( -- number ) HEX: 201 ; inline -: ALUT_ERROR_INVALID_VALUE ( -- number ) HEX: 202 ; inline -: ALUT_ERROR_INVALID_OPERATION ( -- number ) HEX: 203 ; inline -: ALUT_ERROR_NO_CURRENT_CONTEXT ( -- number ) HEX: 204 ; inline -: ALUT_ERROR_AL_ERROR_ON_ENTRY ( -- number ) HEX: 205 ; inline -: ALUT_ERROR_ALC_ERROR_ON_ENTRY ( -- number ) HEX: 206 ; inline -: ALUT_ERROR_OPEN_DEVICE ( -- number ) HEX: 207 ; inline -: ALUT_ERROR_CLOSE_DEVICE ( -- number ) HEX: 208 ; inline -: ALUT_ERROR_CREATE_CONTEXT ( -- number ) HEX: 209 ; inline -: ALUT_ERROR_MAKE_CONTEXT_CURRENT ( -- number ) HEX: 20A ; inline -: ALUT_ERROR_DESTRY_CONTEXT ( -- number ) HEX: 20B ; inline -: ALUT_ERROR_GEN_BUFFERS ( -- number ) HEX: 20C ; inline -: ALUT_ERROR_BUFFER_DATA ( -- number ) HEX: 20D ; inline -: ALUT_ERROR_IO_ERROR ( -- number ) HEX: 20E ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_TYPE ( -- number ) HEX: 20F ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE ( -- number ) HEX: 210 ; inline -: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA ( -- number ) HEX: 211 ; inline -: ALUT_WAVEFORM_SINE ( -- number ) HEX: 100 ; inline -: ALUT_WAVEFORM_SQUARE ( -- number ) HEX: 101 ; inline -: ALUT_WAVEFORM_SAWTOOTH ( -- number ) HEX: 102 ; inline -: ALUT_WAVEFORM_WHITENOISE ( -- number ) HEX: 103 ; inline -: ALUT_WAVEFORM_IMPULSE ( -- number ) HEX: 104 ; inline -: ALUT_LOADER_BUFFER ( -- number ) HEX: 300 ; inline -: ALUT_LOADER_MEMORY ( -- number ) HEX: 301 ; inline +CONSTANT: ALUT_API_MAJOR_VERSION 1 +CONSTANT: ALUT_API_MINOR_VERSION 1 +CONSTANT: ALUT_ERROR_NO_ERROR 0 +CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200 +CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201 +CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202 +CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203 +CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204 +CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205 +CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206 +CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207 +CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208 +CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209 +CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A +CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B +CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C +CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D +CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210 +CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211 +CONSTANT: ALUT_WAVEFORM_SINE HEX: 100 +CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101 +CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102 +CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103 +CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104 +CONSTANT: ALUT_LOADER_BUFFER HEX: 300 +CONSTANT: ALUT_LOADER_MEMORY HEX: 301 FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ; FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ; @@ -234,37 +234,37 @@ FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei SYMBOL: init : init-openal ( -- ) - init get-global expired? [ - f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when - 1337 init set-global - ] when ; + init get-global expired? [ + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when + 1337 init set-global + ] when ; : exit-openal ( -- ) - init get-global expired? [ - alutExit 0 = [ "Could not close OpenAL" throw ] when - f init set-global - ] unless ; + init get-global expired? [ + alutExit 0 = [ "Could not close OpenAL" throw ] when + f init set-global + ] unless ; : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup 2dup underlying>> alGenBuffers swap ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; : create-buffer-from-file ( filename -- buffer ) - alutCreateBufferFromFile dup AL_NONE = [ - "create-buffer-from-file failed" throw - ] when ; + alutCreateBufferFromFile dup AL_NONE = [ + "create-buffer-from-file failed" throw + ] when ; os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) - gen-buffer dup rot load-wav-file - [ alBufferData ] 4keep alutUnloadWAV ; + gen-buffer dup rot load-wav-file + [ alBufferData ] 4keep alutUnloadWAV ; : queue-buffers ( source buffers -- ) [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; @@ -273,29 +273,27 @@ os macosx? "openal.macosx" "openal.other" ? require 1array queue-buffers ; : set-source-param ( source param value -- ) - alSourcei ; + alSourcei ; : get-source-param ( source param -- value ) - 0 dup >r alGetSourcei r> *uint ; + 0 dup [ alGetSourcei ] dip *uint ; : set-buffer-param ( source param value -- ) - alBufferi ; + alBufferi ; : get-buffer-param ( source param -- value ) - 0 dup >r alGetBufferi r> *uint ; + 0 dup [ alGetBufferi ] dip *uint ; -: source-play ( source -- ) - alSourcePlay ; +: source-play ( source -- ) alSourcePlay ; -: source-stop ( source -- ) - alSourceStop ; +: source-stop ( source -- ) alSourceStop ; : check-error ( -- ) - alGetError dup ALUT_ERROR_NO_ERROR = [ - drop - ] [ - alGetString throw - ] if ; + alGetError dup ALUT_ERROR_NO_ERROR = [ + drop + ] [ + alGetString throw + ] if ; : source-playing? ( source -- bool ) - AL_SOURCE_STATE get-source-param AL_PLAYING = ; + AL_SOURCE_STATE get-source-param AL_PLAYING = ; From 5f39a714be67c05b9f8a86c64d4a4616af676fe3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 00:59:50 -0600 Subject: [PATCH 067/170] add some constants to unix --- basis/unix/unix.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 76613934af..a6a0147504 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0 CONSTANT: MAP_SHARED 1 CONSTANT: MAP_PRIVATE 2 +CONSTANT: SEEK_SET 0 +CONSTANT: SEEK_CUR 1 +CONSTANT: SEEK_END 2 + : MAP_FAILED ( -- alien ) -1 ; inline CONSTANT: NGROUPS_MAX 16 From f6f716c4e3a6e6457c9eecfb9e3ab418f5463af4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 01:03:12 -0600 Subject: [PATCH 068/170] unix support for stream seeking --- basis/io/backend/unix/unix.factor | 3 +++ basis/io/buffers/buffers.factor | 3 +++ basis/io/ports/ports.factor | 8 +++++++- core/io/encodings/encodings.factor | 2 ++ core/io/io.factor | 5 ++++- 5 files changed, 19 insertions(+), 2 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index d86a72c665..7340260b2e 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,6 +46,9 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +M: unix (stream-seek) + handle>> fd>> swap SEEK_SET lseek io-error ; + SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 4df081b17d..11fbbf947c 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -27,6 +27,9 @@ M: buffer dispose* ptr>> free ; : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline +: buffer-seek ( n buffer -- ) + (>>pos) ; inline + : buffer-consume ( n buffer -- ) [ + ] change-pos dup [ pos>> ] [ fill>> ] bi < diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1fe717d5ee..dd95e37d72 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors -destructors combinators ; +destructors combinators unix ; IN: io.ports SYMBOL: default-buffer-size @@ -93,6 +93,12 @@ M: input-port stream-read-until ( seps port -- str/f sep/f ) ] [ [ 2drop ] 2dip ] if ] if ; +HOOK: (stream-seek) os ( n stream -- ) + +M: input-port stream-seek ( n stream -- ) + dup check-disposed + 2dup buffer>> buffer-seek (stream-seek) ; + TUPLE: output-port < buffered-port ; : ( handle -- output-port ) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 94d2115478..4693c672a4 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,6 +50,8 @@ M: object f decoder boa ; M: decoder stream-read1 dup >decoder< decode-char fix-read1 ; +M: decoder stream-seek stream>> stream-seek ; + : fix-read ( stream string -- string ) over cr>> [ over cr- diff --git a/core/io/io.factor b/core/io/io.factor index 55cc336ef8..9b606194e0 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,6 +15,8 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) +GENERIC: stream-seek ( n stream -- ) + : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; ! Default streams @@ -27,6 +29,7 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; +: seek ( n -- ) input-stream get stream-seek ; : write1 ( elt -- ) output-stream get stream-write1 ; : write ( seq -- ) output-stream get stream-write ; @@ -82,4 +85,4 @@ PRIVATE> : stream-copy ( in out -- ) [ [ [ write ] each-block ] with-output-stream ] - curry with-input-stream ; \ No newline at end of file + curry with-input-stream ; From 790f3b867c7642505a91284fd854da6563ff40d7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 01:12:03 -0600 Subject: [PATCH 069/170] remove bogus unix depenedency, implement seeking on windows --- basis/io/backend/windows/nt/nt.factor | 2 ++ basis/io/ports/ports.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index c6b24a0a11..52ab06e753 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -82,6 +82,8 @@ M: winnt init-io ( -- ) H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; +M: winnt (stream-seek) ( n stream -- ) 2drop ; + : file-error? ( n -- eof? ) zero? [ GetLastError { diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index dd95e37d72..0f2dcc6e21 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors -destructors combinators unix ; +destructors combinators ; IN: io.ports SYMBOL: default-buffer-size From ec7356446f275353781b80b31f6235d39d4756df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 08:59:50 -0600 Subject: [PATCH 070/170] read ifds for tiff files --- extra/graphics/tiff/tiff.factor | 35 ++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 4676ea2748..34f6c3e4e0 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -1,15 +1,28 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files -kernel pack endian ; +kernel pack endian tools.hexdump constructors sequences arrays +sorting.slots math.order ; IN: graphics.tiff TUPLE: tiff endianness the-answer ifd-offset +ifds ; +CONSTRUCTOR: tiff ( -- tiff ) + V{ } clone >>ifds ; + +TUPLE: ifd count ifd-entries ; + +CONSTRUCTOR: ifd ( count ifd-entries -- ifd ) ; + +TUPLE: ifd-entry tag type count offset ; + +CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; + ERROR: bad-tiff-magic bytes ; @@ -20,6 +33,9 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; +: with-tiff-endianness ( tiff quot -- tiff ) + [ dup endianness>> ] dip with-endianness ; inline + : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -27,10 +43,27 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; +: push-ifd ( tiff ifd -- tiff ) + over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + [ + dup ifd-offset>> seek + 2 read endian> + dup [ read-ifd ] replicate >>ifds + ] with-tiff-endianness ; + : (load-tiff) ( path -- tiff ) binary [ tiff new read-header + read-ifds ] with-file-reader ; : load-tiff ( path -- tiff ) From 723f08ca615e9d9f52345230a086956080fa14a8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 09:52:34 -0600 Subject: [PATCH 071/170] fix buffer-seek --- basis/io/buffers/buffers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 11fbbf947c..bfb6c08471 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -28,7 +28,7 @@ M: buffer dispose* ptr>> free ; fill>> zero? ; inline : buffer-seek ( n buffer -- ) - (>>pos) ; inline + 0 >>fill 0 >>pos 2drop ; inline : buffer-consume ( n buffer -- ) [ + ] change-pos From 044fd02b5cf2200acd59cbd8bed098993f4be418 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 10:07:41 -0600 Subject: [PATCH 072/170] more work on tiff -- parse all the relevant ifd-entries --- extra/graphics/tiff/tiff.factor | 165 ++++++++++++++++++++++++++++++-- 1 file changed, 159 insertions(+), 6 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 34f6c3e4e0..462f75ff79 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order ; +sorting.slots math.order math.parser prettyprint ; IN: graphics.tiff TUPLE: tiff @@ -10,20 +10,135 @@ endianness the-answer ifd-offset ifds -; +processed-ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries ; +TUPLE: ifd count ifd-entries next ; -CONSTRUCTOR: ifd ( count ifd-entries -- ifd ) ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset ; CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +TUPLE: photometric-interpretation color ; + +CONSTRUCTOR: photometric-interpretation ( color -- object ) ; + +SINGLETONS: white-is-zero black-is-zero rgb palette-color ; + +ERROR: bad-photometric-interpretation n ; + +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ white-is-zero ] } + { 1 [ black-is-zero ] } + { 2 [ rgb ] } + { 3 [ palette-color ] } + [ bad-photometric-interpretation ] + } case ; + + +TUPLE: compression method ; + +CONSTRUCTOR: compression ( method -- object ) ; + +SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + +ERROR: bad-compression n ; + +: lookup-compression ( n -- compression ) + { + { 1 [ no-compression ] } + { 2 [ CCITT-2 ] } + { 5 [ lzw ] } + { 32773 [ pack-bits ] } + [ bad-compression ] + } case ; + +TUPLE: image-length n ; +CONSTRUCTOR: image-length ( n -- object ) ; + +TUPLE: image-width n ; +CONSTRUCTOR: image-width ( n -- object ) ; + +TUPLE: x-resolution n ; +CONSTRUCTOR: x-resolution ( n -- object ) ; + +TUPLE: y-resolution n ; +CONSTRUCTOR: y-resolution ( n -- object ) ; + +TUPLE: rows-per-strip n ; +CONSTRUCTOR: rows-per-strip ( n -- object ) ; + +TUPLE: strip-offsets n ; +CONSTRUCTOR: strip-offsets ( n -- object ) ; + +TUPLE: strip-byte-counts n ; +CONSTRUCTOR: strip-byte-counts ( n -- object ) ; + +TUPLE: bits-per-sample n ; +CONSTRUCTOR: bits-per-sample ( n -- object ) ; + +TUPLE: samples-per-pixel n ; +CONSTRUCTOR: samples-per-pixel ( n -- object ) ; + +SINGLETONS: no-resolution-unit +inch-resolution-unit +centimeter-resolution-unit ; + +TUPLE: resolution-unit type ; +CONSTRUCTOR: resolution-unit ( type -- object ) ; + +ERROR: bad-resolution-unit n ; + +: lookup-resolution-unit ( n -- object ) + { + { 1 [ no-resolution-unit ] } + { 2 [ inch-resolution-unit ] } + { 3 [ centimeter-resolution-unit ] } + [ bad-resolution-unit ] + } case ; + + +TUPLE: predictor type ; +CONSTRUCTOR: predictor ( type -- object ) ; + +SINGLETONS: no-predictor horizontal-differencing-predictor ; + +ERROR: bad-predictor n ; + +: lookup-predictor ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: planar-configuration type ; +CONSTRUCTOR: planar-configuration ( type -- object ) ; + +SINGLETONS: chunky planar ; + +ERROR: bad-planar-configuration n ; + +: lookup-planar-configuration ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: new-subfile-type n ; +CONSTRUCTOR: new-subfile-type ( n -- object ) ; + + + ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -56,14 +171,52 @@ ERROR: bad-tiff-magic bytes ; [ dup ifd-offset>> seek 2 read endian> - dup [ read-ifd ] replicate >>ifds + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +! ERROR: unhandled-ifd-entry data n ; + +: unhandled-ifd-entry ; + +: ifd-entry-value ( ifd-entry -- n ) + dup count>> 1 = [ + offset>> + ] [ + [ offset>> seek ] [ count>> read ] bi + ] if ; + +: process-ifd-entry ( ifd-entry -- object ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ ] } + { 256 [ ] } + { 257 [ ] } + { 258 [ ] } + { 259 [ lookup-compression ] } + { 262 [ lookup-photometric-interpretation ] } + { 273 [ ] } + { 277 [ ] } + { 278 [ ] } + { 279 [ ] } + { 282 [ ] } + { 283 [ ] } + { 284 [ ] } + { 296 [ lookup-resolution-unit ] } + { 317 [ lookup-predictor ] } + [ unhandled-ifd-entry swap 2array ] + } case ; + +: process-ifd ( ifd -- processed-ifd ) + ifd-entries>> [ process-ifd-entry ] map ; + : (load-tiff) ( path -- tiff ) binary [ - tiff new + read-header read-ifds + dup ifds>> [ process-ifd ] map + >>processed-ifds ] with-file-reader ; : load-tiff ( path -- tiff ) From bc0521f88a52b7cef23ed77b75d165107ee36449 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 10:30:51 -0600 Subject: [PATCH 073/170] make seeking support the full lseek options, add seeking on output ports, remove seeking from decoders.. --- basis/io/backend/unix/unix.factor | 9 +++++++-- basis/io/ports/ports.factor | 13 +++++++------ core/io/encodings/encodings.factor | 2 -- core/io/io.factor | 6 ++++-- 4 files changed, 18 insertions(+), 12 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 7340260b2e..e39ae3e7f8 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,8 +46,13 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; -M: unix (stream-seek) - handle>> fd>> swap SEEK_SET lseek io-error ; +M: unix (stream-seek) ( n seek-type stream -- ) + swap { + { io:seek-absolute [ SEEK_SET ] } + { io:seek-relative [ SEEK_CUR ] } + { io:seek-end [ SEEK_END ] } + } case + [ handle>> fd>> swap ] dip lseek io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 0f2dcc6e21..4b0336ed26 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -93,12 +93,6 @@ M: input-port stream-read-until ( seps port -- str/f sep/f ) ] [ [ 2drop ] 2dip ] if ] if ; -HOOK: (stream-seek) os ( n stream -- ) - -M: input-port stream-seek ( n stream -- ) - dup check-disposed - 2dup buffer>> buffer-seek (stream-seek) ; - TUPLE: output-port < buffered-port ; : ( handle -- output-port ) @@ -126,6 +120,13 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) +HOOK: (stream-seek) os ( n seek-type stream -- ) + +M: port stream-seek ( n seek-type stream -- ) + dup check-disposed + [ nip buffer>> buffer-seek ] [ (stream-seek) ] 3bi ; + + GENERIC: shutdown ( handle -- ) M: object shutdown drop ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4693c672a4..94d2115478 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,8 +50,6 @@ M: object f decoder boa ; M: decoder stream-read1 dup >decoder< decode-char fix-read1 ; -M: decoder stream-seek stream>> stream-seek ; - : fix-read ( stream string -- string ) over cr>> [ over cr- diff --git a/core/io/io.factor b/core/io/io.factor index 9b606194e0..1cfdaf526e 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,7 +15,8 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) -GENERIC: stream-seek ( n stream -- ) +SINGLETONS: seek-absolute seek-relative seek-end ; +GENERIC: stream-seek ( n seek-type stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -29,7 +30,8 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; -: seek ( n -- ) input-stream get stream-seek ; +: seek-input ( n seek-type -- ) input-stream get stream-seek ; +: seek-output ( n seek-type -- ) output-stream get stream-seek ; : write1 ( elt -- ) output-stream get stream-write1 ; : write ( seq -- ) output-stream get stream-write ; From 44a4c20f230920da2b6b6b6fe45535b6dd476d2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:00:16 -0600 Subject: [PATCH 074/170] update stream seeking on windows for new api --- basis/io/backend/windows/nt/nt.factor | 12 +++++++++++- basis/io/buffers/buffers.factor | 6 +++--- basis/io/ports/ports.factor | 2 +- basis/windows/kernel32/kernel32.factor | 2 +- 4 files changed, 16 insertions(+), 6 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 52ab06e753..7479c0a0bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -82,7 +82,17 @@ M: winnt init-io ( -- ) H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; -M: winnt (stream-seek) ( n stream -- ) 2drop ; +ERROR: invalid-file-size n ; + +: handle>file-size ( handle -- n ) + 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; + +M: winnt (stream-seek) ( n seek-type stream -- ) + swap { + { seek-absolute [ handle>> (>>ptr) ] } + { seek-relative [ handle>> [ + ] change-ptr drop ] } + { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + } case ; : file-error? ( n -- eof? ) zero? [ diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index bfb6c08471..a647f27dfc 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -21,15 +21,15 @@ M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) swap >>fill 0 >>pos drop ; +: buffer-reset-hard ( buffer -- ) + 0 >>fill 0 >>pos drop ; + : buffer-capacity ( buffer -- n ) [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline -: buffer-seek ( n buffer -- ) - 0 >>fill 0 >>pos 2drop ; inline - : buffer-consume ( n buffer -- ) [ + ] change-pos dup [ pos>> ] [ fill>> ] bi < diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 4b0336ed26..1f7fc5f115 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -124,7 +124,7 @@ HOOK: (stream-seek) os ( n seek-type stream -- ) M: port stream-seek ( n seek-type stream -- ) dup check-disposed - [ nip buffer>> buffer-seek ] [ (stream-seek) ] 3bi ; + [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ; GENERIC: shutdown ( handle -- ) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d3e823f844..3494e83e83 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ; FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ; -! FUNCTION: GetFileSizeEx +FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ; FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ; FUNCTION: DWORD GetFileType ( HANDLE hFile ) ; ! FUNCTION: GetFirmwareEnvironmentVariableA From 2820b9fc9981c9c6aef47844b858ae7b1e8a7ab9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:23:00 -0600 Subject: [PATCH 075/170] better error handling on unix seek, unit tests --- core/io/io-tests.factor | 65 ++++++++++++++++++++++++++++++++++++++++- core/io/io.factor | 1 + 2 files changed, 65 insertions(+), 1 deletion(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 009ba3a9e7..8bfc52432d 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,6 @@ USING: arrays io io.files kernel math parser strings system tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences ; +io.encodings.binary sequences io.files.unique ; IN: io.tests [ f ] [ @@ -10,3 +10,66 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test + +[ B{ 3 2 3 4 5 } ] +[ + "seek-test1" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 3 } ] +[ + "seek-test2" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 5 0 3 } ] +[ + "seek-test3" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 3 } ] +[ + B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ + set-file-contents + ] [ + [ + -3 seek-end seek-input 1 read + ] with-file-reader + ] 2bi +] unit-test + +[ B{ 2 } ] +[ + B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ + set-file-contents + ] [ + [ + 3 seek-absolute seek-input + -2 seek-relative seek-input + 1 read + ] with-file-reader + ] 2bi +] unit-test diff --git a/core/io/io.factor b/core/io/io.factor index 1cfdaf526e..11a2a6d1a8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,6 +15,7 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) +ERROR: bad-seek-type type ; SINGLETONS: seek-absolute seek-relative seek-end ; GENERIC: stream-seek ( n seek-type stream -- ) From 959ef7a7374de067b21ccfe4d403082641008811 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:24:12 -0600 Subject: [PATCH 076/170] better error handling for backends --- basis/io/backend/unix/unix.factor | 1 + basis/io/backend/windows/nt/nt.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index e39ae3e7f8..3372f15cd9 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -51,6 +51,7 @@ M: unix (stream-seek) ( n seek-type stream -- ) { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } { io:seek-end [ SEEK_END ] } + [ io:bad-seek-type ] } case [ handle>> fd>> swap ] dip lseek io-error ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 7479c0a0bb..7b96e883dd 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -92,6 +92,7 @@ M: winnt (stream-seek) ( n seek-type stream -- ) { seek-absolute [ handle>> (>>ptr) ] } { seek-relative [ handle>> [ + ] change-ptr drop ] } { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + [ bad-seek-type ] } case ; : file-error? ( n -- eof? ) From f499cab2fbc94ce34a98ec0b1de3aacf7acfb1c3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:35:13 -0600 Subject: [PATCH 077/170] seek -> new seeking --- extra/graphics/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 462f75ff79..5c1fd4ec65 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -169,7 +169,7 @@ ERROR: bad-tiff-magic bytes ; : read-ifds ( tiff -- tiff ) [ - dup ifd-offset>> seek + dup ifd-offset>> seek-input 2 read endian> dup [ read-ifd ] replicate 4 read endian> @@ -184,7 +184,7 @@ ERROR: bad-tiff-magic bytes ; dup count>> 1 = [ offset>> ] [ - [ offset>> seek ] [ count>> read ] bi + [ offset>> seek-input ] [ count>> read ] bi ] if ; : process-ifd-entry ( ifd-entry -- object ) From 8097b52b12656b0ddd34a4e7b75947742d905acd Mon Sep 17 00:00:00 2001 From: Philipp Bruschweiler Date: Sun, 8 Feb 2009 01:03:35 +0100 Subject: [PATCH 078/170] initial infix vocab --- extra/infix/ast/ast.factor | 8 + extra/infix/infix-docs.factor | 38 ++++ extra/infix/infix-tests.factor | 45 +++++ extra/infix/infix.factor | 99 +++++++++++ extra/infix/parser/parser-tests.factor | 175 +++++++++++++++++++ extra/infix/parser/parser.factor | 30 ++++ extra/infix/tokenizer/tokenizer-tests.factor | 20 +++ extra/infix/tokenizer/tokenizer.factor | 21 +++ 8 files changed, 436 insertions(+) create mode 100644 extra/infix/ast/ast.factor create mode 100644 extra/infix/infix-docs.factor create mode 100644 extra/infix/infix-tests.factor create mode 100644 extra/infix/infix.factor create mode 100644 extra/infix/parser/parser-tests.factor create mode 100644 extra/infix/parser/parser.factor create mode 100644 extra/infix/tokenizer/tokenizer-tests.factor create mode 100644 extra/infix/tokenizer/tokenizer.factor diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor new file mode 100644 index 0000000000..0bc22feeb7 --- /dev/null +++ b/extra/infix/ast/ast.factor @@ -0,0 +1,8 @@ +IN: infix.ast + +TUPLE: ast-number value ; +TUPLE: ast-local name ; +TUPLE: ast-array name index ; +TUPLE: ast-function name arguments ; +TUPLE: ast-op left right op ; +TUPLE: ast-negation term ; diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor new file mode 100644 index 0000000000..7a4febb514 --- /dev/null +++ b/extra/infix/infix-docs.factor @@ -0,0 +1,38 @@ +USING: help.syntax help.markup prettyprint locals ; +IN: infix + +HELP: [infix +{ $syntax "[infix ... infix]" } +{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix 8+2*3 infix] ." + "14" + } $nl + { $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :" + { $example + "USING: infix locals math.functions prettyprint ;" + "IN: scratchpad" + ":: quadratic-equation ( a b c -- z- z+ )" + " [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]" + " [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;" + "1 0 -1 quadratic-equation . ." + "1.0\n-1.0" + } +} ; + +HELP: [infix| +{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" } +{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ." + "452.16" + } +} ; + +{ POSTPONE: [infix POSTPONE: [infix| } related-words diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor new file mode 100644 index 0000000000..5ee6468131 --- /dev/null +++ b/extra/infix/infix-tests.factor @@ -0,0 +1,45 @@ +USING: infix infix.private kernel locals math math.functions +tools.test ; +IN: infix.tests + +[ 0 ] [ [infix 0 infix] ] unit-test +[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test +[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test +[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test +[ 1 ] [ [infix 2- + 1 + -5* + 0 infix] ] unit-test + +[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] | + r*r*pi infix] ] unit-test +[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test +[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test +[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test + +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test +[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test +[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test + +[ 0.0 ] [ [infix sin(0) infix] ] unit-test +[ 10 ] [ [infix lcm(2,5) infix] ] unit-test +[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test + +[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values +[ f ] [ 1 \ drop check-word ] unit-test ! no return value +[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args +: no-stack-effect-declared + ; +[ 0 \ no-stack-effect-declared check-word ] must-fail + +: qux ( -- x ) 2 ; +[ t ] [ 0 \ qux check-word ] unit-test +[ 8 ] [ [infix qux()*3+2 infix] ] unit-test +: foobar ( x -- y ) 1 + ; +[ t ] [ 1 \ foobar check-word ] unit-test +[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test +: stupid_function ( x x x x x -- y ) + + + + ; +[ t ] [ 5 \ stupid_function check-word ] unit-test +[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test + +[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor new file mode 100644 index 0000000000..31cd1cbe1f --- /dev/null +++ b/extra/infix/infix.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators combinators.short-circuit +effects fry infix.parser infix.ast kernel locals.parser +locals.types math multiline namespaces parser quotations +sequences summary words ; +IN: infix + +local-word ( string -- word ) + locals get at? [ local-not-defined ] unless ; + +: select-op ( string -- word ) + { + { "+" [ [ + ] ] } + { "-" [ [ - ] ] } + { "*" [ [ * ] ] } + { "/" [ [ / ] ] } + [ drop [ mod ] ] + } case ; + +GENERIC: infix-codegen ( ast -- quot/number ) + +M: ast-number infix-codegen value>> ; + +M: ast-local infix-codegen + name>> >local-word ; + +M: ast-array infix-codegen + [ index>> infix-codegen prepare-operand ] + [ name>> >local-word ] bi '[ @ _ nth ] ; + +M: ast-op infix-codegen + [ left>> infix-codegen ] [ right>> infix-codegen ] + [ op>> select-op ] tri + 2over [ number? ] both? [ call ] [ + [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ] + ] if ; + +M: ast-negation infix-codegen + term>> infix-codegen + { + { [ dup number? ] [ neg ] } + { [ dup callable? ] [ '[ @ neg ] ] } + [ '[ _ neg ] ] ! local word + } cond ; + +ERROR: bad-stack-effect word ; +M: bad-stack-effect summary + drop "Words used in infix must declare a stack effect and return exactly one value" ; + +: check-word ( argcount word -- ? ) + dup stack-effect [ ] [ bad-stack-effect ] ?if + [ in>> length ] [ out>> length ] bi + [ = ] dip 1 = and ; + +: find-and-check ( args argcount string -- quot ) + dup search [ ] [ no-word ] ?if + [ nip ] [ check-word ] 2bi + [ 1quotation compose ] [ bad-stack-effect ] if ; + +: arguments-codegen ( seq -- quot ) + dup empty? [ drop [ ] ] [ + [ infix-codegen prepare-operand ] + [ compose ] map-reduce + ] if ; + +M: ast-function infix-codegen + [ arguments>> [ arguments-codegen ] [ length ] bi ] + [ name>> ] bi find-and-check ; + +: [infix-parse ( end -- result/quot ) + parse-multiline-string build-infix-ast + infix-codegen prepare-operand ; +PRIVATE> + +: [infix + "infix]" [infix-parse parsed \ call parsed ; parsing + + + +: [infix| + "|" parse-bindings "infix]" parse-infix-locals + parsed-lambda ; parsing diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor new file mode 100644 index 0000000000..0a0288c41b --- /dev/null +++ b/extra/infix/parser/parser-tests.factor @@ -0,0 +1,175 @@ +USING: infix.ast infix.parser infix.tokenizer tools.test ; +IN: infix.parser.tests + +\ parse-infix must-infer +\ build-infix-ast must-infer + +[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test +[ T{ ast-negation f T{ ast-number { value 1 } } } ] +[ "-1" build-infix-ast ] unit-test +[ T{ ast-op + { left + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + } + { right T{ ast-number { value 4 } } } + { op "+" } +} ] [ "1+2+4" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "*" } + } + } + { op "+" } +} ] [ "1+2*3" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } +} ] [ "(1+2)" build-infix-ast ] unit-test + +[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test +[ "-" build-infix-ast ] must-fail + +[ T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "%" } + } + } + } +} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test + +[ T{ ast-op + { left + T{ ast-op + { left + T{ ast-function + { name "bar" } + { arguments V{ } } + } + } + { right + T{ ast-array + { name "baz" } + { index + T{ ast-op + { left + T{ ast-op + { left + T{ ast-number + { value 2 } + } + } + { right + T{ ast-number + { value 3 } + } + } + { op "/" } + } + } + { right + T{ ast-number { value 4 } } + } + { op "+" } + } + } + } + } + { op "+" } + } + } + { right T{ ast-number { value 2 } } } + { op "/" } +} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } + { op "+" } +} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test + +[ T{ ast-negation + { term + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number { value 2 } } + T{ ast-negation + { term T{ ast-number { value 3 } } } + } + } + } + } + } +} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test + +[ T{ ast-array + { name "arr" } + { index + T{ ast-op + { left + T{ ast-negation + { term + T{ ast-op + { left + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number + { value 2 } + } + } + } + } + } + { right + T{ ast-negation + { term + T{ ast-number + { value 1 } + } + } + } + } + { op "+" } + } + } + } + } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } +} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test + +[ "foo bar baz" build-infix-ast ] must-fail +[ "1+2/4+" build-infix-ast ] must-fail +[ "quaz(2/3,)" build-infix-ast ] must-fail diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor new file mode 100644 index 0000000000..beaf3c335d --- /dev/null +++ b/extra/infix/parser/parser.factor @@ -0,0 +1,30 @@ +USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences +strings vectors ; +IN: infix.parser + +EBNF: parse-infix +Number = . ?[ ast-number? ]? +Identifier = . ?[ string? ]? +Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]] +Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]] + +FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]] + | Sum:s => [[ s 1vector ]] + +Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]] + | "(" Sum:s ")" => [[ s ]] + | Number | Array | Function + | Identifier => [[ ast-local boa ]] + +Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]] + | Terminal + +Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]] + | Product + +End = !(.) +Expression = Sum End +;EBNF + +: build-infix-ast ( string -- ast ) + tokenize-infix parse-infix ; diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor new file mode 100644 index 0000000000..7e1fb005ef --- /dev/null +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -0,0 +1,20 @@ +USING: infix.ast infix.tokenizer tools.test ; +IN: infix.tokenizer.tests + +\ tokenize-infix must-infer +[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test +[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] +[ "3/(3+4)" tokenize-infix ] unit-test +[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test +[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ] +[ "arr[x+3]" tokenize-infix ] unit-test +[ "1.0.4" tokenize-infix ] must-fail +[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ] +[ "+]3.4,bar" tokenize-infix ] unit-test +[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test +[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test +[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ] +[ "(1+2)" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ] +[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor new file mode 100644 index 0000000000..8c1a1b4a18 --- /dev/null +++ b/extra/infix/tokenizer/tokenizer.factor @@ -0,0 +1,21 @@ +USING: infix.ast kernel peg peg.ebnf math.parser sequences +strings ; +IN: infix.tokenizer + +EBNF: tokenize-infix +Letter = [a-zA-Z] +Digit = [0-9] +Digits = Digit+ +Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]] + | Digits => [[ >string string>number ast-number boa ]] +Space = " " | "\n" | "\r" | "\t" +Spaces = Space* => [[ ignore ]] +NameFirst = Letter | "_" => [[ CHAR: _ ]] +NameRest = NameFirst | Digit +Name = NameFirst NameRest* => [[ first2 swap prefix >string ]] +Special = [+*/%(),] | "-" => [[ CHAR: - ]] + | "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]] +Tok = Spaces (Name | Number | Special ) +End = !(.) +Toks = Tok* Spaces End +;EBNF From 36e5536110a213126cbcee0fd4084b7250799bd0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Feb 2009 20:39:32 -0600 Subject: [PATCH 079/170] Mention string encoding in >string --- core/strings/strings-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d40cd982d8..9a1671b126 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -53,8 +53,9 @@ HELP: 1string HELP: >string { $values { "seq" "a sequence of characters" } { "str" string } } -{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; +{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." } +{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } From f08c8dd66d0c840558a61e8b8dad1a7da0bb3841 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 21:23:35 -0600 Subject: [PATCH 080/170] fix some compile bugz --- extra/graphics/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 5c1fd4ec65..e66ebcc6bd 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -169,7 +169,7 @@ ERROR: bad-tiff-magic bytes ; : read-ifds ( tiff -- tiff ) [ - dup ifd-offset>> seek-input + dup ifd-offset>> seek-absolute seek-input 2 read endian> dup [ read-ifd ] replicate 4 read endian> @@ -184,7 +184,7 @@ ERROR: bad-tiff-magic bytes ; dup count>> 1 = [ offset>> ] [ - [ offset>> seek-input ] [ count>> read ] bi + [ offset>> seek-absolute seek-input ] [ count>> read ] bi ] if ; : process-ifd-entry ( ifd-entry -- object ) From f36ec3f0c5da15143f2f6bd1ab3ca88006f14255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Feb 2009 23:04:55 -0600 Subject: [PATCH 081/170] Add nsum, nspread and nweave to generalizations --- .../generalizations-docs.factor | 52 +++++++++++++++---- .../generalizations-tests.factor | 9 ++++ basis/generalizations/generalizations.factor | 19 ++++++- 3 files changed, 67 insertions(+), 13 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 912f69587e..ac8e14c05a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -30,6 +30,10 @@ HELP: narray { nsequence narray } related-words +HELP: nsum +{ $values { "n" integer } } +{ $description "Adds the top " { $snippet "n" } " stack values." } ; + HELP: firstn { $values { "n" integer } } { $description "A generalization of " { $link first } ", " @@ -238,6 +242,11 @@ HELP: ncleave } } ; +HELP: nspread +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link spread } " that can work for any quotation arity." +} ; + HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -250,6 +259,17 @@ HELP: mnswap } } ; +HELP: nweave +{ $values { "n" integer } } +{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } +{ $examples + { $example + "USING: arrays kernel generalizations prettyprint ;" + "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." + "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" + } +} ; + HELP: n*quot { $values { "n" integer } { "seq" sequence } @@ -299,18 +319,14 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " -"macros where the arity of the input quotations depends on an " -"input parameter." -$nl -"Generalized sequence operations:" +ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsection narray } { $subsection nsequence } { $subsection firstn } { $subsection nappend } -{ $subsection nappend-as } -"Generated stack shuffle operations:" +{ $subsection nappend-as } ; + +ARTICLE: "shuffle-generalizations" "Generalized shuffle words" { $subsection ndup } { $subsection npick } { $subsection nrot } @@ -319,14 +335,28 @@ $nl { $subsection ndrop } { $subsection ntuck } { $subsection mnswap } -"Generalized combinators:" +{ $subsection nweave } ; + +ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } { $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } -"Generalized quotation construction:" +{ $subsection nspread } ; + +ARTICLE: "other-generalizations" "Additional generalizations" { $subsection ncurry } -{ $subsection nwith } ; +{ $subsection nwith } +{ $subsection nsum } ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " +"macros where the arity of the input quotations depends on an " +"input parameter." +{ $subsection "sequence-generalizations" } +{ $subsection "shuffle-generalizations" } +{ $subsection "combinator-generalizations" } +{ $subsection "other-generalizations" } ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 35e02f08b4..7ede271d01 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -53,3 +53,12 @@ IN: generalizations.tests [ 4 nappend ] must-infer [ 4 { } nappend-as ] must-infer + +[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test +{ 4 1 } [ 4 nsum ] must-infer-as + +[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test +{ 3 5 } [ 2 nweave ] must-infer-as + +[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] +[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test \ No newline at end of file diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 4692fd20db..9b2b2456c2 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math combinators @@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- ) MACRO: narray ( n -- ) '[ _ { } nsequence ] ; +MACRO: nsum ( n -- ) + 1- [ + ] n*quot ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ [ [ '[ [ _ ] dip nth-unsafe ] ] map ] @@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- ) [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi compose ; +MACRO: nspread ( quots n -- ) + over empty? [ 2drop [ ] ] [ + [ [ but-last ] dip ] + [ [ peek ] dip ] 2bi + swap + '[ [ _ _ nspread ] _ ndip @ ] + ] if ; + MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] spread>quot ; + 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + +MACRO: nweave ( n -- ) + [ dup [ '[ _ _ mnswap ] ] with map ] keep + '[ _ _ ncleave ] ; : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline From aa6166adf20004d792503fd90e8778047d5f7578 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 8 Feb 2009 00:20:56 -0600 Subject: [PATCH 082/170] Fix typo --- extra/websites/concatenative/concatenative.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index c1d62c6cda..35a1129338 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -65,7 +65,7 @@ SYMBOL: dh-file "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global - "slava@factorcode.org" insomniac-recipients set-global + { "slava@factorcode.org" } insomniac-recipients set-global init-factor-db ; : init-testing ( -- ) From 16312f67111b3954507865cf5cba2aceb379db9d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 10:35:30 -0600 Subject: [PATCH 083/170] clean up stream-seek with some suggestions from slava --- basis/io/backend/unix/unix.factor | 4 ++-- basis/io/backend/windows/nt/nt.factor | 8 ++++---- basis/io/buffers/buffers.factor | 3 --- basis/io/ports/ports.factor | 13 +++++++++---- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 3372f15cd9..f5e6426859 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,14 +46,14 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; -M: unix (stream-seek) ( n seek-type stream -- ) +M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ handle>> fd>> swap ] dip lseek io-error ; + [ fd>> swap ] dip lseek io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 7b96e883dd..107f1902e3 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,11 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; -M: winnt (stream-seek) ( n seek-type stream -- ) +M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ handle>> (>>ptr) ] } - { seek-relative [ handle>> [ + ] change-ptr drop ] } - { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ (>>ptr) ] } + { seek-relative [ [ + ] change-ptr drop ] } + { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } [ bad-seek-type ] } case ; diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index a647f27dfc..4df081b17d 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -21,9 +21,6 @@ M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) swap >>fill 0 >>pos drop ; -: buffer-reset-hard ( buffer -- ) - 0 >>fill 0 >>pos drop ; - : buffer-capacity ( buffer -- n ) [ size>> ] [ fill>> ] bi - ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1f7fc5f115..1a58d4200b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -120,12 +120,17 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) -HOOK: (stream-seek) os ( n seek-type stream -- ) +HOOK: seek-handle os ( n seek-type handle -- ) -M: port stream-seek ( n seek-type stream -- ) - dup check-disposed - [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ; +M: input-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ buffer>> 0 swap buffer-reset ] + [ handle>> seek-handle ] tri ; +M: output-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ stream-flush ] + [ handle>> seek-handle ] tri ; GENERIC: shutdown ( handle -- ) From 69f4899e11cd69c01c572d9acd68e1ed20029cf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:51:02 -0600 Subject: [PATCH 084/170] document stream seeking --- core/io/io-docs.factor | 53 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index d7534ddb50..5d8aa6a88f 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -68,6 +68,51 @@ HELP: stream-copy { $description "Copies the contents of one stream into another, closing both streams when done." } $io-error ; + +HELP: stream-seek +{ $values + { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" } +} +{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl + "Three methods of seeking are supported:" + { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } } +} +{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ; + +HELP: seek-absolute +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the beginning of the stream." } ; + +HELP: seek-end +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ; + +HELP: seek-relative +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the current position of the stream pointer." } ; + + +HELP: seek-input +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ; + +HELP: seek-output +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ; + HELP: input-stream { $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ; @@ -196,6 +241,8 @@ $nl { $subsection stream-write } "This word is only required for string output streams:" { $subsection stream-nl } +"This word is for streams that allow seeking:" +{ $subsection stream-seek } "For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; @@ -249,6 +296,8 @@ $nl { $subsection read-partial } "If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" { $subsection readln } +"Seeking on the default input stream:" +{ $subsection seek-input } "A pair of combinators for rebinding the " { $link input-stream } " variable:" { $subsection with-input-stream } { $subsection with-input-stream* } @@ -256,7 +305,7 @@ $nl { $subsection output-stream } "Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." $nl -"Words writing to the default input stream:" +"Words writing to the default output stream:" { $subsection flush } { $subsection write1 } { $subsection write } @@ -265,6 +314,8 @@ $nl { $subsection print } { $subsection nl } { $subsection bl } +"Seeking on the default output stream:" +{ $subsection seek-output } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } From fef602b1857ab649d882461e76522388cefb24a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:58:39 -0600 Subject: [PATCH 085/170] remove superfluous flush from io tests --- core/io/io-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 8bfc52432d..d227ebeadf 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -16,7 +16,7 @@ IN: io.tests "seek-test1" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output B{ 3 } write ] with-file-writer ] [ @@ -29,7 +29,7 @@ IN: io.tests "seek-test2" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output + B{ 1 2 3 4 5 } write -1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ @@ -42,7 +42,7 @@ IN: io.tests "seek-test3" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output + B{ 1 2 3 4 5 } write 1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ From bba15986972c5b3918fc56cbea83b489c533f199 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:59:32 -0600 Subject: [PATCH 086/170] move io tests into io.files --- core/io/files/files-tests.factor | 65 ++++++++++++++++++++++++++++++++ core/io/io-tests.factor | 63 ------------------------------- 2 files changed, 65 insertions(+), 63 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f9702fd133..423eb38144 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -75,3 +75,68 @@ USE: debugger.threads [ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test + +! File seeking tests +[ B{ 3 2 3 4 5 } ] +[ + "seek-test1" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 3 } ] +[ + "seek-test2" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write -1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 5 0 3 } ] +[ + "seek-test3" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 3 } ] +[ + B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ + set-file-contents + ] [ + [ + -3 seek-end seek-input 1 read + ] with-file-reader + ] 2bi +] unit-test + +[ B{ 2 } ] +[ + B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ + set-file-contents + ] [ + [ + 3 seek-absolute seek-input + -2 seek-relative seek-input + 1 read + ] with-file-reader + ] 2bi +] unit-test + diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index d227ebeadf..9e931279d7 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -10,66 +10,3 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test - -[ B{ 3 2 3 4 5 } ] -[ - "seek-test1" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 0 seek-absolute seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 3 } ] -[ - "seek-test2" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write -1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 5 0 3 } ] -[ - "seek-test3" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 3 } ] -[ - B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ - set-file-contents - ] [ - [ - -3 seek-end seek-input 1 read - ] with-file-reader - ] 2bi -] unit-test - -[ B{ 2 } ] -[ - B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ - set-file-contents - ] [ - [ - 3 seek-absolute seek-input - -2 seek-relative seek-input - 1 read - ] with-file-reader - ] 2bi -] unit-test From 08ad6ca1162f54d7264d95dc02740405b4c332c2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 8 Feb 2009 23:22:23 +0100 Subject: [PATCH 087/170] FUEL: use factor.com instead of factor.exe as default binary under Windows. --- misc/fuel/fuel-connection.el | 8 ++++++-- misc/fuel/fuel-listener.el | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 14c4d0b36f..f180d0f2b4 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -144,8 +144,12 @@ (add-hook 'comint-redirect-hook 'fuel-con--comint-redirect-hook nil t)) -(defadvice comint-redirect-setup (after fuel-con--advice activate) - (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)) +(defadvice comint-redirect-setup + (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo)) + (with-current-buffer comint-buffer + (when fuel-con--connection + (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)))) +(ad-activate 'comint-redirect-setup) (defun fuel-con--comint-preoutput-filter (str) (when (string-match fuel-con--comint-finished-regex str) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index d0898de04f..b8bf4d4b7f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -32,7 +32,7 @@ (defcustom fuel-listener-factor-binary (expand-file-name (cond ((eq system-type 'windows-nt) - "factor.exe") + "factor.com") ((eq system-type 'darwin) "Factor.app/Contents/MacOS/factor") (t "factor")) From da45cbe96d1a3f242abefd125eac56301c0a6937 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 17:13:28 -0600 Subject: [PATCH 088/170] Rewriting basis/wrap with Knuth's algorithm. Minor API changes will probably break Slava's unmerged UI changes --- basis/wrap/wrap-docs.factor | 28 +++--- basis/wrap/wrap-tests.factor | 87 +++++++++++------ basis/wrap/wrap.factor | 181 ++++++++++++++++++++++++++--------- 3 files changed, 212 insertions(+), 84 deletions(-) diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index c94e12907f..09ddec36ed 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words." -{ $subsection wrap } -{ $subsection word } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." +{ $subsection wrap-elements } +{ $subsection element } +{ $subsection } ; HELP: wrap-lines { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } @@ -27,15 +27,15 @@ HELP: wrap-indented-string { $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } { $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; -HELP: wrap -{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } } -{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; +HELP: wrap-elements +{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; -HELP: word -{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link } "." } -{ $see-also wrap } ; +HELP: element +{ $class-description "An element is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } +{ $see-also wrap-elements } ; -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } -{ $description "Creates a " { $link word } " object with the given parameters." } -{ $see-also wrap } ; +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } } +{ $description "Creates an " { $link element } " object with the given parameters." } +{ $see-also wrap-elements } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index ba5168a1c2..98d0b712f7 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,49 +6,77 @@ IN: wrap.tests [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 2 t } } { - T{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 2 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map ] unit-test [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 3 9 t } } { - T{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map +] unit-test + +[ + { + { + T{ element f 1 10 t } + T{ element f 1 10 f } + T{ element f 3 9 t } + } + { + T{ element f 2 10 f } + T{ element f 3 9 t } + } + { + T{ element f 4 10 f } + T{ element f 5 10 f } + } + } +] [ + { + T{ element f 1 10 t } + T{ element f 1 10 f } + T{ element f 3 9 t } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map ] unit-test [ @@ -75,8 +103,13 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots of\nspaces" ] +[ "this text\nhas lots\nof spaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] [ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index e93509b58e..458d2f86d1 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,70 +1,165 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel namespaces make splitting -math math.order fry assocs accessors ; +USING: kernel sequences math arrays locals fry accessors splitting +make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap -! Word wrapping/line breaking -- not Unicode-aware - -TUPLE: word key width break? ; - -C: word - word -: break-here? ( column word -- ? ) - break?>> not [ width get > ] [ drop f ] if ; +: word-length ( word -- n ) + [ black>> ] [ white>> ] bi + ; -: walk ( n words -- n ) - ! If on a break, take the rest of the breaks - ! If not on a break, go back until you hit a break - 2dup bounds-check? [ - 2dup nth break?>> - [ [ break?>> not ] find-from drop ] - [ [ break?>> ] find-last-from drop 1+ ] if - ] [ drop ] if ; +TUPLE: cons cdr car ; ! This order works out better +C: cons -: find-optimal-break ( words -- n ) - [ 0 ] keep - [ [ width>> + dup ] keep break-here? ] find drop nip - [ 1 max swap walk ] [ drop f ] if* ; +: >cons< ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; -: (wrap) ( words -- ) +: list-each ( list quot -- ) + over [ + [ [ car>> ] dip call ] + [ [ cdr>> ] dip list-each ] 2bi + ] [ 2drop ] if ; inline recursive + +: singleton? ( list -- ? ) + { [ ] [ cdr>> not ] } 1&& ; + +: ( elt -- list ) + f swap ; + +: list>array ( list -- array ) + [ [ , ] list-each ] { } make ; + +: lists>arrays ( lists -- arrays ) + [ [ list>array , ] list-each ] { } make ; + +TUPLE: paragraph lines head-width tail-cost ; +C: paragraph + +SYMBOL: line-max +SYMBOL: line-ideal + +: deviation ( length -- n ) + line-ideal get - sq ; + +: top-fits? ( paragraph -- ? ) + [ head-width>> ] + [ lines>> singleton? line-ideal line-max ? get ] bi <= ; + +: fits? ( paragraph -- ? ) + ! Make this not count spaces at end + { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ; + +:: min-by ( seq quot -- elt ) + f 1.0/0.0 seq [| key value new | + new quot call :> newvalue + newvalue value < [ new newvalue ] [ key value ] if + ] each drop ; inline + +: paragraph-cost ( paragraph -- cost ) + [ head-width>> deviation ] + [ tail-cost>> ] bi + ; + +: min-cost ( paragraphs -- paragraph ) + [ paragraph-cost ] min-by ; + +: new-line ( paragraph word -- paragraph ) + [ [ lines>> ] [ ] bi* ] + [ nip black>> ] + [ drop paragraph-cost ] 2tri + ; + +: glue ( paragraph word -- paragraph ) + [ [ lines>> >cons< ] dip ] + [ [ head-width>> ] [ word-length ] bi* + ] + [ drop tail-cost>> ] 2tri + ; + +: wrap-step ( paragraphs word -- paragraphs ) + [ '[ _ glue ] map ] + [ [ min-cost ] dip new-line ] + 2bi prefix + [ fits? ] filter ; + +: 1paragraph ( word -- paragraph ) + [ ] + [ black>> ] bi + 0 ; + +: post-process ( paragraph -- array ) + lines>> lists>arrays + [ [ contents>> ] map ] map ; + +: initialize ( words -- words paragraph ) + unclip-slice 1paragraph 1array ; + +: wrap ( words line-max line-ideal -- paragraph ) [ - dup find-optimal-break - [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* - ] unless-empty ; + line-ideal set + line-max set + initialize + [ wrap-step ] reduce + min-cost + post-process + ] with-scope ; -: intersperse ( seq elt -- seq' ) - [ '[ _ , ] [ , ] interleave ] { } make ; +PRIVATE> + +TUPLE: element key width break? ; +C: element + +> ] map sum ; + +: make-word ( whites blacks -- word ) + [ append ] [ [ elements-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-elements ( seq -- half-words ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/word ) + dup first first break?>> + [ unclip-slice f swap make-word ] + [ f ] if ; + +: make-words ( seq f/word -- words ) + [ 2 [ ?first2 make-word ] map ] dip + [ prefix ] when* ; + +: elements>words ( seq -- newseq ) + split-elements ?first-break make-words ; + +PRIVATE> + +: wrap-elements ( elements line-max line-ideal -- lines ) + [ elements>words ] 2dip wrap [ concat ] map ; + + ] map - " " 1 t intersperse + [ dup length 1 ] map ] map ; : join-words ( wrapped-lines -- lines ) - [ - [ break?>> ] trim-slice - [ key>> ] map concat - ] map ; + [ " " join ] map ; : join-lines ( strings -- string ) "\n" join ; PRIVATE> -: wrap ( words width -- lines ) - width [ - [ (wrap) ] { } make - ] with-variable ; - : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; From c069add10b86dc8038354e5b91c1b2d3a8da5c87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:34:17 -0600 Subject: [PATCH 089/170] fix using lists --- core/io/files/files-tests.factor | 10 ++++------ core/io/io-tests.factor | 4 +--- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 423eb38144..d7fc3851e2 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,8 +1,7 @@ -USING: tools.test io.files io.files.private io.files.temp -io.directories io.encodings.8-bit arrays make system -io.encodings.binary io threads kernel continuations -io.encodings.ascii sequences strings accessors -io.encodings.utf8 math destructors namespaces ; +USING: arrays debugger.threads destructors io io.directories +io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.files io.files.private io.files.temp io.files.unique kernel +make math sequences system threads tools.test ; IN: io.files.tests \ exists? must-infer @@ -139,4 +138,3 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test - diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 9e931279d7..cf6b935215 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,4 @@ -USING: arrays io io.files kernel math parser strings system -tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences io.files.unique ; +USING: io parser tools.test words ; IN: io.tests [ f ] [ From 83252cce04ef5864f6c38eb2343b94e974d5a05c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:37:54 -0600 Subject: [PATCH 090/170] working on tiff --- extra/graphics/tiff/tiff.factor | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index e66ebcc6bd..f0b3f9337e 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,20 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint ; +sorting.slots math.order math.parser prettyprint classes ; IN: graphics.tiff TUPLE: tiff endianness the-answer ifd-offset -ifds -processed-ifds ; +ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next ; +TUPLE: ifd count ifd-entries next processed-tags strips ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; @@ -137,8 +136,6 @@ ERROR: bad-planar-configuration n ; TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; - - ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -176,6 +173,12 @@ ERROR: bad-tiff-magic bytes ; [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +: read-strips ( ifd -- ifd ) + dup processed-tags>> + [ [ strip-byte-counts instance? ] find nip n>> ] + [ [ strip-offsets instance? ] find nip n>> ] bi + [ seek-absolute seek-input read ] { } 2map-as >>strips ; + ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; @@ -207,17 +210,18 @@ ERROR: bad-tiff-magic bytes ; [ unhandled-ifd-entry swap 2array ] } case ; -: process-ifd ( ifd -- processed-ifd ) - ifd-entries>> [ process-ifd-entry ] map ; +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; : (load-tiff) ( path -- tiff ) binary [ read-header read-ifds - dup ifds>> [ process-ifd ] map - >>processed-ifds + dup ifds>> [ process-ifd read-strips drop ] each ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; + +! TODO: duplicate ifds = error, seeking out of bounds = error From 0e8986176f7597d23b5908968c7785ad3b4a02a2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 18:24:22 -0600 Subject: [PATCH 091/170] Adding failing unit test to wrap (must-infer) --- basis/wrap/wrap-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 98d0b712f7..933238fddc 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -113,3 +113,6 @@ word wrap."> [ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer +\ wrap-elements must-infer From 1818ea5136cd5515772b4c29d6c978378ffae1d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 18:42:11 -0600 Subject: [PATCH 092/170] update README.txt --- README.txt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/README.txt b/README.txt index 98616539d2..d60bf03130 100755 --- a/README.txt +++ b/README.txt @@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI. * Running Factor on Windows XP/Vista +The Factor runtime is compiled into two binaries: + + factor.com - a Windows console application + factor.exe - a Windows native application, without a console + If you did not download the binary package, you can bootstrap Factor in -the command prompt: +the command prompt using the console application: - factor.exe -i=boot..image + factor.com -i=boot..image -Once bootstrapped, double-clicking factor.exe starts the Factor UI. +Once bootstrapped, double-clicking factor.exe or factor.com starts +the Factor UI. To run the listener in the command prompt: - factor.exe -run=listener + factor.com -run=listener * The Factor FAQ From b529df965234019bfdd98a472636dd875bc910a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 20:18:30 -0600 Subject: [PATCH 093/170] handle seeking before the file start on windows, add a unit test for this --- basis/io/backend/windows/nt/nt.factor | 11 ++++++++--- core/io/files/files-tests.factor | 6 ++++++ 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 107f1902e3..6f283ac1bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,16 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; +ERROR: seek-before-start n ; + +: set-seek-ptr ( n handle -- ) + [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; + M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ (>>ptr) ] } - { seek-relative [ [ + ] change-ptr drop ] } - { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ set-seek-ptr ] } + { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } + { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } [ bad-seek-type ] } case ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d7fc3851e2..152d1bb85d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -138,3 +138,9 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test + +[ + "seek-test6" unique-file binary [ + -10 seek-absolute seek-input + ] with-file-reader +] must-fail From ea46845ac16fdce6122812b3733a029e9b090dea Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 20:32:11 -0600 Subject: [PATCH 094/170] Slight furnace cleanup --- basis/furnace/chloe-tags/chloe-tags.factor | 13 ++++++++++--- basis/furnace/utilities/utilities-docs.factor | 6 +++--- basis/furnace/utilities/utilities.factor | 12 ++++++------ 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index d7d9ae9ebb..8003ab208b 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -81,11 +81,18 @@ CHLOE: a CHLOE: base compile-a-url [ [XML /> XML] ] [xml-code] ; +: hidden-nested-fields ( -- xml ) + nested-forms get " " join f like nested-forms-key + hidden-form-field ; + +: render-hidden ( for -- xml ) + "," split [ hidden render>xml ] map ; + : compile-hidden-form-fields ( for -- ) '[ - _ [ "," split [ hidden render>xml ] map ] [ f ] if* - nested-forms get " " join f like nested-forms-key hidden-form-field>xml - [ [ modify-form ] each-responder ] with-string-writer + _ render-hidden + hidden-nested-fields + form-modifications [XML
<-><-><->
XML] ] [code] ; diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..62f73d4f09 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -20,8 +20,8 @@ HELP: each-responder { $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } +{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } } +{ $description "Renders an HTML hidden form field tag as XML." } { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example @@ -38,7 +38,7 @@ HELP: link-attr { $examples "Conversation scope adds attributes to link tags." } ; HELP: modify-form -{ $values { "responder" "a responder" } } +{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } } { $contract "Emits hidden form fields using " { $link hidden-form-field } "." } { $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index a2d4c4d996..2f998e039a 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; -GENERIC: modify-form ( responder -- ) +GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form drop ; +M: object modify-form f ; -: hidden-form-field>xml ( value name -- xml ) +: form-modifications ( -- xml ) + [ [ modify-form [ , ] when ] each-responder ] { } make ; + +: hidden-form-field ( value name -- xml ) over [ [XML name=<->/> XML] ] [ drop ] if ; -: hidden-form-field ( value name -- ) - hidden-form-field>xml write-xml ; - : nested-forms-key "__n" ; : request-params ( request -- assoc ) From c3f5dc2e96d52cdc4e361f08ae201540365ce5b2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 21:17:59 -0600 Subject: [PATCH 095/170] Help-lint edit for furnace.utilities --- basis/furnace/utilities/utilities.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 2f998e039a..4fc68f7735 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -79,10 +79,10 @@ M: object link-attr 2drop ; GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form f ; +M: object modify-form drop f ; : form-modifications ( -- xml ) - [ [ modify-form [ , ] when ] each-responder ] { } make ; + [ [ modify-form [ , ] when* ] each-responder ] { } make ; : hidden-form-field ( value name -- xml ) over [ From b65b88364c46b8c21b4f36e302bc406e0861bf49 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:12:11 -0600 Subject: [PATCH 096/170] Updating lots of things to use call( -- ) --- basis/alien/c-types/c-types.factor | 4 ++-- basis/cocoa/messages/messages.factor | 4 ++-- .../compiler/tree/propagation/inlining/inlining.factor | 7 ++++--- basis/help/lint/lint.factor | 10 +++++----- basis/html/templates/chloe/chloe.factor | 4 ++-- basis/html/templates/chloe/compiler/compiler.factor | 6 +++--- basis/html/templates/fhtml/fhtml.factor | 4 ++-- basis/ui/tools/interactor/interactor.factor | 5 ++--- basis/ui/ui.factor | 4 ++-- 9 files changed, 24 insertions(+), 24 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index cf5daa1562..89b3572daf 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math 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 fry ; +accessors combinators effects continuations fry call ; IN: alien.c-types DEFER: @@ -258,7 +258,7 @@ M: long-long-type box-return ( type -- ) unclip [ [ dup word? [ - def>> { } swap with-datastack first + def>> call( -- object ) ] when ] map ] dip prefix diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a0b0e89a0d..60bdde262c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math namespaces make parser quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry -generalizations specialized-arrays.direct.alien ; +generalizations specialized-arrays.direct.alien call ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -83,7 +83,7 @@ class-init-hooks global [ H{ } clone or ] change-at : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ assert-depth ] when* + drop over class-init-hooks get at [ call( -- ) ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index f3b3238b4e..06d8d4f733 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math math.order +USING: accessors kernel arrays sequences math math.order call math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart @@ -181,8 +181,9 @@ SYMBOL: history "custom-inlining" word-prop ; : inline-custom ( #call word -- ? ) - [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack - first object swap eliminate-dispatch ; + [ dup ] [ "custom-inlining" word-prop ] bi* + call( #call -- word/quot/f ) + object swap eliminate-dispatch ; : inline-instance-check ( #call word -- ? ) over in-d>> second value-info literal>> dup class? diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index b5f8b78ea3..57f64459c8 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval vocabs.parser words.symbol values grouping unicode.categories -sequences.deep ; +sequences.deep call ; IN: help.lint SYMBOL: vocabs-quot @@ -15,9 +15,9 @@ SYMBOL: vocabs-quot : check-example ( element -- ) [ rest [ - but-last "\n" join 1vector - [ (eval>string) ] with-datastack - peek "\n" ?tail drop + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop ] keep peek assert= ] vocabs-quot get call ; @@ -145,7 +145,7 @@ M: help-error error. bi ; : check-something ( obj quot -- ) - flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline + flush '[ _ call( -- ) ] swap '[ _ , ] recover ; inline : check-word ( word -- ) [ with-file-vocabs ] vocabs-quot set diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 89d00e1f6e..eafa3c3a5d 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml -logging continuations +logging call xml.data xml.writer xml.syntax strings html.forms html @@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ; template-cache get clear-assoc ; M: chloe call-template* - template-quot assert-depth ; + template-quot call( -- ) ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 394b5ef359..1a1abc9f7b 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present -xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax continuations ; +xml.writer xml.data xml.entities html.forms call +html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry assert-depth ] + [ curry call( -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index c419c4a197..e76a812bef 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files +assocs fry vocabs.parser parser lexer io io.files call io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] assert-depth ; + '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; INSTANCE: fhtml template diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 40da6ebafc..eb2eef3742 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -5,7 +5,7 @@ hashtables io io.styles kernel math math.order math.vectors models models.delay namespaces parser lexer prettyprint quotations sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar -ui.gadgets.presentations ui.gadgets.worlds ui.gestures +ui.gadgets.presentations ui.gadgets.worlds ui.gestures call definitions calendar concurrency.flags concurrency.mailboxes ui.tools.workspace accessors sets destructors fry vocabs.parser ; IN: ui.tools.interactor @@ -82,8 +82,7 @@ M: interactor model-changed mailbox>> mailbox-put ; : clear-input ( interactor -- ) - #! The with-datastack is a kludge to make it infer. Stupid. - model>> 1array [ clear-doc ] with-datastack drop ; + model>> [ clear-doc ] call( model -- ) ; : interactor-finish ( interactor -- ) [ editor-string ] keep diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 37ce4ea499..78f150987f 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables -concurrency.flags sets accessors calendar ; +concurrency.flags sets accessors calendar call ; IN: ui ! Assoc mapping aliens to gadgets @@ -140,7 +140,7 @@ SYMBOL: ui-hook layout-queued redraw-worlds send-queued-gestures - ] assert-depth + ] call( -- ) ] [ ui-error ] recover ; SYMBOL: ui-thread From af9f5112d45beb02023aee377f3d0fbf6b2ceae5 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:39:22 -0600 Subject: [PATCH 097/170] Adding call( -- ) --- basis/call/call-tests.factor | 10 ++++++++++ basis/call/call.factor | 24 ++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 basis/call/call-tests.factor create mode 100644 basis/call/call.factor diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor new file mode 100644 index 0000000000..4a59a6d2fb --- /dev/null +++ b/basis/call/call-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: math tools.test call kernel ; +IN: call.tests + +[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test +[ 1 2 [ + ] call( -- z ) ] must-fail +[ 1 2 [ + ] call( x y -- z a ) ] must-fail +[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ [ + ] call( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor new file mode 100644 index 0000000000..363b024dff --- /dev/null +++ b/basis/call/call.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel macros fry summary sequences generalizations accessors +continuations effects.parser parser ; +IN: call + +ERROR: wrong-values values quot length-required ; + +M: wrong-values summary + drop "Wrong number of values returned from quotation" ; + + + +MACRO: call-effect ( effect -- quot ) + [ in>> length ] [ out>> length ] bi + '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; + +: call( + ")" parse-effect parsed \ call-effect parsed ; parsing From c4aa14b9d96d0a55b6c94e2441d952cf056ddfcc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:06:03 -0600 Subject: [PATCH 098/170] Making lazy lists compile, and using them where applicable --- basis/persistent/deques/deques.factor | 14 ++-- basis/wrap/wrap-docs.factor | 26 +++---- basis/wrap/wrap-tests.factor | 84 +++++++++++------------ basis/wrap/wrap.factor | 97 ++++++++++++--------------- extra/lists/lazy/lazy-tests.factor | 8 ++- extra/lists/lazy/lazy.factor | 22 +++--- extra/lists/lists.factor | 5 +- extra/promises/promises.factor | 10 +-- 8 files changed, 125 insertions(+), 141 deletions(-) diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index be63d807b9..ece1cda772 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,6 +1,6 @@ ! Copyback (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math ; +USING: kernel accessors math lists ; QUALIFIED: sequences IN: persistent.deques @@ -9,25 +9,23 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. cons : each ( list quot: ( elt -- ) -- ) over - [ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ] + [ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ] [ 2drop ] if ; inline recursive : reduce ( list start quot -- end ) swapd each ; inline : reverse ( list -- reversed ) - f [ swap ] reduce ; + f [ swap cons ] reduce ; : length ( list -- length ) 0 [ drop 1+ ] reduce ; : cut ( list index -- back front-reversed ) - f swap [ [ [ cdr>> ] [ car>> ] bi ] dip ] times ; + f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ; : split-reverse ( list -- back-reversed front ) dup length 2/ cut [ reverse ] bi@ ; @@ -49,7 +47,7 @@ PRIVATE> > ] [ back>> ] bi deque boa ; inline + [ front>> cons ] [ back>> ] bi deque boa ; inline PRIVATE> : push-front ( deque item -- newdeque ) @@ -60,7 +58,7 @@ PRIVATE> > car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline + [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) back>> [ split-reverse deque boa remove ] diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 09ddec36ed..59c0352bc7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." -{ $subsection wrap-elements } -{ $subsection element } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." +{ $subsection wrap-segments } +{ $subsection segment } +{ $subsection } ; HELP: wrap-lines { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } @@ -27,15 +27,15 @@ HELP: wrap-indented-string { $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } { $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; -HELP: wrap-elements -{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +HELP: wrap-segments +{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } { $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; -HELP: element -{ $class-description "An element is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } -{ $see-also wrap-elements } ; +HELP: segment +{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } +{ $see-also wrap-segments } ; -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } } -{ $description "Creates an " { $link element } " object with the given parameters." } -{ $see-also wrap-elements } ; +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } } +{ $description "Creates a " { $link segment } " object with the given parameters." } +{ $see-also wrap-segments } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 933238fddc..eeea3850d5 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,77 +6,77 @@ IN: wrap.tests [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } } { - T{ element f 2 10 f } - T{ element f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ @@ -115,4 +115,4 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer -\ wrap-elements must-infer +\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 458d2f86d1..f54c858bf4 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,39 +1,28 @@ -USING: kernel sequences math arrays locals fry accessors splitting -make combinators.short-circuit namespaces grouping splitting.monotonic ; +USING: kernel sequences math arrays locals fry accessors +lists splitting call make combinators.short-circuit namespaces +grouping splitting.monotonic ; IN: wrap word +TUPLE: element contents black white ; +C: element -: word-length ( word -- n ) +: element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -TUPLE: cons cdr car ; ! This order works out better -C: cons +: swons ( cdr car -- cons ) + swap cons ; -: >cons< ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; +: unswons ( cons -- cdr car ) + [ cdr ] [ car ] bi ; -: list-each ( list quot -- ) - over [ - [ [ car>> ] dip call ] - [ [ cdr>> ] dip list-each ] 2bi - ] [ 2drop ] if ; inline recursive - -: singleton? ( list -- ? ) - { [ ] [ cdr>> not ] } 1&& ; - -: ( elt -- list ) - f swap ; - -: list>array ( list -- array ) - [ [ , ] list-each ] { } make ; +: 1list? ( list -- ? ) + { [ ] [ cdr +nil+ = ] } 1&& ; : lists>arrays ( lists -- arrays ) - [ [ list>array , ] list-each ] { } make ; + [ list>seq ] lmap>array ; TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -46,11 +35,11 @@ SYMBOL: line-ideal : top-fits? ( paragraph -- ? ) [ head-width>> ] - [ lines>> singleton? line-ideal line-max ? get ] bi <= ; + [ lines>> 1list? line-ideal line-max ? get ] bi <= ; : fits? ( paragraph -- ? ) ! Make this not count spaces at end - { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ; + { [ lines>> car 1list? ] [ top-fits? ] } 1|| ; :: min-by ( seq quot -- elt ) f 1.0/0.0 seq [| key value new | @@ -65,26 +54,26 @@ SYMBOL: line-ideal : min-cost ( paragraphs -- paragraph ) [ paragraph-cost ] min-by ; -: new-line ( paragraph word -- paragraph ) - [ [ lines>> ] [ ] bi* ] +: new-line ( paragraph element -- paragraph ) + [ [ lines>> ] [ 1list ] bi* swons ] [ nip black>> ] [ drop paragraph-cost ] 2tri ; -: glue ( paragraph word -- paragraph ) - [ [ lines>> >cons< ] dip ] - [ [ head-width>> ] [ word-length ] bi* + ] +: glue ( paragraph element -- paragraph ) + [ [ lines>> unswons ] dip swons swons ] + [ [ head-width>> ] [ element-length ] bi* + ] [ drop tail-cost>> ] 2tri ; -: wrap-step ( paragraphs word -- paragraphs ) +: wrap-step ( paragraphs element -- paragraphs ) [ '[ _ glue ] map ] [ [ min-cost ] dip new-line ] 2bi prefix [ fits? ] filter ; -: 1paragraph ( word -- paragraph ) - [ ] +: 1paragraph ( element -- paragraph ) + [ 1list 1list ] [ black>> ] bi 0 ; @@ -92,10 +81,10 @@ SYMBOL: line-ideal lines>> lists>arrays [ [ contents>> ] map ] map ; -: initialize ( words -- words paragraph ) +: initialize ( elements -- elements paragraph ) unclip-slice 1paragraph 1array ; -: wrap ( words line-max line-ideal -- paragraph ) +: wrap ( elements line-max line-ideal -- paragraph ) [ line-ideal set line-max set @@ -107,50 +96,50 @@ SYMBOL: line-ideal PRIVATE> -TUPLE: element key width break? ; -C: element +TUPLE: segment key width break? ; +C: segment > ] map sum ; -: make-word ( whites blacks -- word ) - [ append ] [ [ elements-length ] bi@ ] 2bi ; +: make-element ( whites blacks -- element ) + [ append ] [ [ segments-length ] bi@ ] 2bi ; : ?first2 ( seq -- first/f second/f ) [ 0 swap ?nth ] [ 1 swap ?nth ] bi ; -: split-elements ( seq -- half-words ) +: split-segments ( seq -- half-elements ) [ [ break?>> ] bi@ = ] monotonic-split ; -: ?first-break ( seq -- newseq f/word ) +: ?first-break ( seq -- newseq f/element ) dup first first break?>> - [ unclip-slice f swap make-word ] + [ unclip-slice f swap make-element ] [ f ] if ; -: make-words ( seq f/word -- words ) - [ 2 [ ?first2 make-word ] map ] dip +: make-elements ( seq f/element -- elements ) + [ 2 [ ?first2 make-element ] map ] dip [ prefix ] when* ; -: elements>words ( seq -- newseq ) - split-elements ?first-break make-words ; +: segments>elements ( seq -- newseq ) + split-segments ?first-break make-elements ; PRIVATE> -: wrap-elements ( elements line-max line-ideal -- lines ) - [ elements>words ] 2dip wrap [ concat ] map ; +: wrap-segments ( segments line-max line-ideal -- lines ) + [ segments>elements ] 2dip wrap [ concat ] map ; ] map + [ dup length 1 ] map ] map ; -: join-words ( wrapped-lines -- lines ) +: join-elements ( wrapped-lines -- lines ) [ " " join ] map ; : join-lines ( strings -- string ) @@ -159,7 +148,7 @@ PRIVATE> PRIVATE> : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor index 5749f94364..03221841c1 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! USING: lists lists.lazy tools.test kernel math io sequences ; IN: lists.lazy.tests @@ -27,3 +26,10 @@ IN: lists.lazy.tests [ { 4 5 6 } ] [ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array ] unit-test + +[ [ ] lmap ] must-infer +[ [ ] lmap>array ] must-infer +[ [ drop ] foldr ] must-infer +[ [ drop ] foldl ] must-infer +[ [ drop ] leach ] must-infer +[ lnth ] must-infer diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index e60fcbaadf..213285e643 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -1,12 +1,7 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 -! Updated by James Cash, June 2008 -! USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors ; +quotations promises combinators io lists accessors call ; IN: lists.lazy M: promise car ( promise -- car ) @@ -86,7 +81,7 @@ C: lazy-map M: lazy-map car ( lazy-map -- car ) [ cons>> car ] keep - quot>> call ; + quot>> call( old -- new ) ; M: lazy-map cdr ( lazy-map -- cdr ) [ cons>> cdr ] keep @@ -130,7 +125,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call + [ cons>> uncons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -150,7 +145,7 @@ M: lazy-while cdr ( lazy-while -- cdr ) [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep quot>> call not ; + [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; @@ -160,7 +155,7 @@ C: lazy-filter over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ cons>> car ] [ quot>> ] bi call ; + [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ; : skip ( lazy-filter -- ) dup cons>> cdr >>cons drop ; @@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep - quot>> dup slip lfrom-by ; + quot>> [ call( old -- new ) ] keep lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car ) dup car>> dup [ nip ] [ - drop dup stream>> over quot>> call + drop dup stream>> over quot>> + call( stream -- value ) >>car ] if ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index bf822889e3..5568b9d53e 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words locals ; - IN: lists ! List Protocol @@ -46,7 +45,7 @@ M: object nil? drop f ; : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; -: 3car ( cons -- car caar caaar ) +: 3car ( cons -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) @@ -109,4 +108,4 @@ M: object nil? drop f ; [ 2over call [ tuck [ call ] 2dip ] when pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive -INSTANCE: cons list \ No newline at end of file +INSTANCE: cons list diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 38366697ea..bec2761e53 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,10 +1,6 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 - -USING: arrays kernel sequences math vectors arrays namespaces +USING: arrays kernel sequences math vectors arrays namespaces call make quotations parser effects stack-checker words accessors ; IN: promises @@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ; #! promises quotation on the stack. Re-forcing the promise #! will return the same value and not recall the quotation. dup forced?>> [ - dup quot>> call >>value + dup quot>> call( -- value ) >>value t >>forced? ] unless value>> ; From 89e3eb6fa312ce7fd2ab777d8768fb9cd3e5ce2c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:49:05 -0600 Subject: [PATCH 099/170] Moving lists to basis --- basis/html/templates/chloe/compiler/compiler.factor | 2 +- basis/html/templates/fhtml/fhtml.factor | 2 +- {extra => basis}/lists/authors.txt | 0 {extra => basis}/lists/lazy/authors.txt | 0 {extra => basis}/lists/lazy/examples/authors.txt | 0 {extra => basis}/lists/lazy/examples/examples-tests.factor | 0 {extra => basis}/lists/lazy/examples/examples.factor | 0 {extra => basis}/lists/lazy/lazy-docs.factor | 0 {extra => basis}/lists/lazy/lazy-tests.factor | 0 {extra => basis}/lists/lazy/lazy.factor | 0 {extra => basis}/lists/lazy/old-doc.html | 0 {extra => basis}/lists/lazy/summary.txt | 0 {extra => basis}/lists/lazy/tags.txt | 0 {extra => basis}/lists/lists-docs.factor | 0 {extra => basis}/lists/lists-tests.factor | 0 {extra => basis}/lists/lists.factor | 0 {extra => basis}/lists/summary.txt | 0 {extra => basis}/lists/tags.txt | 0 18 files changed, 2 insertions(+), 2 deletions(-) rename {extra => basis}/lists/authors.txt (100%) rename {extra => basis}/lists/lazy/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/examples-tests.factor (100%) rename {extra => basis}/lists/lazy/examples/examples.factor (100%) rename {extra => basis}/lists/lazy/lazy-docs.factor (100%) rename {extra => basis}/lists/lazy/lazy-tests.factor (100%) rename {extra => basis}/lists/lazy/lazy.factor (100%) rename {extra => basis}/lists/lazy/old-doc.html (100%) rename {extra => basis}/lists/lazy/summary.txt (100%) rename {extra => basis}/lists/lazy/tags.txt (100%) rename {extra => basis}/lists/lists-docs.factor (100%) rename {extra => basis}/lists/lists-tests.factor (100%) rename {extra => basis}/lists/lists.factor (100%) rename {extra => basis}/lists/summary.txt (100%) rename {extra => basis}/lists/tags.txt (100%) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 1a1abc9f7b..3cb7523bdc 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry call( -- ) ] + [ call( tag -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index e76a812bef..78202d6460 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; + [ path>> utf8 file-contents eval-template ] call( filename -- ) ; INSTANCE: fhtml template diff --git a/extra/lists/authors.txt b/basis/lists/authors.txt similarity index 100% rename from extra/lists/authors.txt rename to basis/lists/authors.txt diff --git a/extra/lists/lazy/authors.txt b/basis/lists/lazy/authors.txt similarity index 100% rename from extra/lists/lazy/authors.txt rename to basis/lists/lazy/authors.txt diff --git a/extra/lists/lazy/examples/authors.txt b/basis/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lists/lazy/examples/authors.txt rename to basis/lists/lazy/examples/authors.txt diff --git a/extra/lists/lazy/examples/examples-tests.factor b/basis/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lists/lazy/examples/examples-tests.factor rename to basis/lists/lazy/examples/examples-tests.factor diff --git a/extra/lists/lazy/examples/examples.factor b/basis/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lists/lazy/examples/examples.factor rename to basis/lists/lazy/examples/examples.factor diff --git a/extra/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor similarity index 100% rename from extra/lists/lazy/lazy-docs.factor rename to basis/lists/lazy/lazy-docs.factor diff --git a/extra/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor similarity index 100% rename from extra/lists/lazy/lazy-tests.factor rename to basis/lists/lazy/lazy-tests.factor diff --git a/extra/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor similarity index 100% rename from extra/lists/lazy/lazy.factor rename to basis/lists/lazy/lazy.factor diff --git a/extra/lists/lazy/old-doc.html b/basis/lists/lazy/old-doc.html similarity index 100% rename from extra/lists/lazy/old-doc.html rename to basis/lists/lazy/old-doc.html diff --git a/extra/lists/lazy/summary.txt b/basis/lists/lazy/summary.txt similarity index 100% rename from extra/lists/lazy/summary.txt rename to basis/lists/lazy/summary.txt diff --git a/extra/lists/lazy/tags.txt b/basis/lists/lazy/tags.txt similarity index 100% rename from extra/lists/lazy/tags.txt rename to basis/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/basis/lists/lists-docs.factor similarity index 100% rename from extra/lists/lists-docs.factor rename to basis/lists/lists-docs.factor diff --git a/extra/lists/lists-tests.factor b/basis/lists/lists-tests.factor similarity index 100% rename from extra/lists/lists-tests.factor rename to basis/lists/lists-tests.factor diff --git a/extra/lists/lists.factor b/basis/lists/lists.factor similarity index 100% rename from extra/lists/lists.factor rename to basis/lists/lists.factor diff --git a/extra/lists/summary.txt b/basis/lists/summary.txt similarity index 100% rename from extra/lists/summary.txt rename to basis/lists/summary.txt diff --git a/extra/lists/tags.txt b/basis/lists/tags.txt similarity index 100% rename from extra/lists/tags.txt rename to basis/lists/tags.txt From 57ac121d2b87ab5c3cfd541ec898403e4a0ce273 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 00:33:30 -0600 Subject: [PATCH 100/170] adding execute( -- ) and documentation for basis/call --- basis/call/call-docs.factor | 32 ++++++++++++++++++++++++++++++++ basis/call/call-tests.factor | 5 +++++ basis/call/call.factor | 8 +++++++- 3 files changed, 44 insertions(+), 1 deletion(-) create mode 100644 basis/call/call-docs.factor diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor new file mode 100644 index 0000000000..463bfdac09 --- /dev/null +++ b/basis/call/call-docs.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax quotations effects words ; +IN: call + +ABOUT: "call" + +ARTICLE: "call" "Calling code with known stack effects" +"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +{ $subsection call-effect } +{ $subsection execute-effect } ; + +HELP: call( +{ $syntax "[ ] call( foo -- bar )" } +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; + +HELP: call-effect +{ $values { "quot" quotation } { "effect" effect } } +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; + +HELP: execute( +{ $syntax "word execute( foo -- bar )" } +{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ; + +HELP: execute-effect +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; + +{ execute-effect call-effect } related-words +{ POSTPONE: call( POSTPONE: execute( } related-words diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 4a59a6d2fb..a2bd11b06a 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -8,3 +8,8 @@ IN: call.tests [ 1 2 [ + ] call( x y -- z a ) ] must-fail [ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test [ [ + ] call( x y -- z ) ] must-infer + +[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test +[ 1 2 \ + execute( -- z ) ] must-fail +[ 1 2 \ + execute( x y -- z a ) ] must-fail +[ \ + execute( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor index 363b024dff..9b49acf64a 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros fry summary sequences generalizations accessors -continuations effects.parser parser ; +continuations effects.parser parser words ; IN: call ERROR: wrong-values values quot length-required ; @@ -22,3 +22,9 @@ MACRO: call-effect ( effect -- quot ) : call( ")" parse-effect parsed \ call-effect parsed ; parsing + +: execute-effect ( word effect -- ) + [ [ execute ] curry ] dip call-effect ; inline + +: execute( + ")" parse-effect parsed \ execute-effect parsed ; parsing From 3e5ec77439381fe12318d4faecc925a953f7cace Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 01:12:32 -0600 Subject: [PATCH 101/170] Splitting up basis/wrap into three vocabs --- basis/wrap/strings/strings-docs.factor | 25 +++++ basis/wrap/strings/strings-tests.factor | 41 ++++++++ basis/wrap/strings/strings.factor | 29 ++++++ basis/wrap/words/words-docs.factor | 25 +++++ basis/wrap/words/words-tests.factor | 82 ++++++++++++++++ basis/wrap/words/words.factor | 40 ++++++++ basis/wrap/wrap-docs.factor | 36 +------- basis/wrap/wrap-tests.factor | 118 ------------------------ basis/wrap/wrap.factor | 66 +------------ basis/xml/writer/writer.factor | 2 +- 10 files changed, 248 insertions(+), 216 deletions(-) create mode 100644 basis/wrap/strings/strings-docs.factor create mode 100644 basis/wrap/strings/strings-tests.factor create mode 100644 basis/wrap/strings/strings.factor create mode 100644 basis/wrap/words/words-docs.factor create mode 100644 basis/wrap/words/words-tests.factor create mode 100644 basis/wrap/words/words.factor delete mode 100644 basis/wrap/wrap-tests.factor diff --git a/basis/wrap/strings/strings-docs.factor b/basis/wrap/strings/strings-docs.factor new file mode 100644 index 0000000000..e20780d3ac --- /dev/null +++ b/basis/wrap/strings/strings-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup strings math ; +IN: wrap.strings + +ABOUT: "wrap.strings" + +ARTICLE: "wrap.strings" "String word wrapping" +"The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font." +{ $subsection wrap-lines } +{ $subsection wrap-string } +{ $subsection wrap-indented-string } ; + +HELP: wrap-lines +{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } +{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; + +HELP: wrap-string +{ $values { "string" string } { "width" integer } { "newstring" string } } +{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; + +HELP: wrap-indented-string +{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } +{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; + diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor new file mode 100644 index 0000000000..0bea9b5d32 --- /dev/null +++ b/basis/wrap/strings/strings-tests.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: wrap.strings tools.test multiline ; +IN: wrap.strings.tests + +[ + <" This is a +long piece +of text +that we +wish to +word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 10 + wrap-string +] unit-test + +[ + <" This is a + long piece + of text + that we + wish to + word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 12 + " " wrap-indented-string +] unit-test + +[ "this text\nhas lots\nof spaces" ] +[ "this text has lots of spaces" 12 wrap-string ] unit-test + +[ "hello\nhow\nare\nyou\ntoday?" ] +[ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor new file mode 100644 index 0000000000..7009352f2a --- /dev/null +++ b/basis/wrap/strings/strings.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: wrap kernel sequences fry splitting math ; +IN: wrap.strings + + ] map + ] map ; + +: join-elements ( wrapped-lines -- lines ) + [ " " join ] map ; + +: join-lines ( strings -- string ) + "\n" join ; + +PRIVATE> + +: wrap-lines ( lines width -- newlines ) + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; + +: wrap-string ( string width -- newstring ) + wrap-lines join-lines ; + +: wrap-indented-string ( string width indent -- newstring ) + [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor new file mode 100644 index 0000000000..422aea0ac3 --- /dev/null +++ b/basis/wrap/words/words-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math kernel ; +IN: wrap.words + +ABOUT: "wrap.words" + +ARTICLE: "wrap.words" "Word object wrapping" +"The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings." +{ $subsection wrap-words } +{ $subsection word } +{ $subsection } ; + +HELP: wrap-words +{ $values { "words" { "a sequence of " { $instance word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; + +HELP: word +{ $class-description "A word is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link } "." } +{ $see-also wrap-words } ; + +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } +{ $description "Creates a " { $link word } " object with the given parameters." } +{ $see-also wrap-words } ; diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor new file mode 100644 index 0000000000..7598b382ba --- /dev/null +++ b/basis/wrap/words/words-tests.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test wrap.words sequences ; +IN: wrap.words.tests + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + } + { + T{ word f 2 10 f } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +\ wrap-words must-infer diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor new file mode 100644 index 0000000000..00f257a5cf --- /dev/null +++ b/basis/wrap/words/words.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel splitting.monotonic accessors wrap grouping ; +IN: wrap.words + +TUPLE: word key width break? ; +C: word + +> ] map sum ; + +: make-element ( whites blacks -- element ) + [ append ] [ [ words-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-words ( seq -- half-elements ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/element ) + dup first first break?>> + [ unclip-slice f swap make-element ] + [ f ] if ; + +: make-elements ( seq f/element -- elements ) + [ 2 [ ?first2 make-element ] map ] dip + [ prefix ] when* ; + +: words>elements ( seq -- newseq ) + split-words ?first-break make-elements ; + +PRIVATE> + +: wrap-words ( words line-max line-ideal -- lines ) + [ words>elements ] 2dip wrap [ concat ] map ; + diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 59c0352bc7..feac7c51a7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -6,36 +6,6 @@ IN: wrap ABOUT: "wrap" ARTICLE: "wrap" "Word wrapping" -"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:" -{ $subsection wrap-lines } -{ $subsection wrap-string } -{ $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." -{ $subsection wrap-segments } -{ $subsection segment } -{ $subsection } ; - -HELP: wrap-lines -{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } -{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; - -HELP: wrap-string -{ $values { "string" string } { "width" integer } { "newstring" string } } -{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; - -HELP: wrap-indented-string -{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } -{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; - -HELP: wrap-segments -{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } -{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; - -HELP: segment -{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } -{ $see-also wrap-segments } ; - -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } } -{ $description "Creates a " { $link segment } " object with the given parameters." } -{ $see-also wrap-segments } ; +"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. Wrapping can take place based on simple strings, assumed to be monospace, or abstract word objects." +{ $vocab-subsection "String word wrapping" "wrap.strings" } +{ $vocab-subsection "Word object wrapping" "wrap.words" } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor deleted file mode 100644 index eeea3850d5..0000000000 --- a/basis/wrap/wrap-tests.factor +++ /dev/null @@ -1,118 +0,0 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test wrap multiline sequences ; -IN: wrap.tests - -[ - { - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 2 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 2 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - { - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - { - { - T{ segment f 1 10 t } - T{ segment f 1 10 f } - T{ segment f 3 9 t } - } - { - T{ segment f 2 10 f } - T{ segment f 3 9 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 t } - T{ segment f 1 10 f } - T{ segment f 3 9 t } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - <" This is a -long piece -of text -that we -wish to -word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 10 - wrap-string -] unit-test - -[ - <" This is a - long piece - of text - that we - wish to - word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 12 - " " wrap-indented-string -] unit-test - -[ "this text\nhas lots\nof spaces" ] -[ "this text has lots of spaces" 12 wrap-string ] unit-test - -[ "hello\nhow\nare\nyou\ntoday?" ] -[ "hello how are you today?" 3 wrap-string ] unit-test - -[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test -[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test -[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test -[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test - -\ wrap-string must-infer -\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index f54c858bf4..55fe10283a 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,10 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math arrays locals fry accessors lists splitting call make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap - element @@ -93,65 +93,3 @@ SYMBOL: line-ideal min-cost post-process ] with-scope ; - -PRIVATE> - -TUPLE: segment key width break? ; -C: segment - -> ] map sum ; - -: make-element ( whites blacks -- element ) - [ append ] [ [ segments-length ] bi@ ] 2bi ; - -: ?first2 ( seq -- first/f second/f ) - [ 0 swap ?nth ] - [ 1 swap ?nth ] bi ; - -: split-segments ( seq -- half-elements ) - [ [ break?>> ] bi@ = ] monotonic-split ; - -: ?first-break ( seq -- newseq f/element ) - dup first first break?>> - [ unclip-slice f swap make-element ] - [ f ] if ; - -: make-elements ( seq f/element -- elements ) - [ 2 [ ?first2 make-element ] map ] dip - [ prefix ] when* ; - -: segments>elements ( seq -- newseq ) - split-segments ?first-break make-elements ; - -PRIVATE> - -: wrap-segments ( segments line-max line-ideal -- lines ) - [ segments>elements ] 2dip wrap [ concat ] map ; - - ] map - ] map ; - -: join-elements ( wrapped-lines -- lines ) - [ " " join ] map ; - -: join-lines ( strings -- string ) - "\n" join ; - -PRIVATE> - -: wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; - -: wrap-string ( string width -- newstring ) - wrap-lines join-lines ; - -: wrap-indented-string ( string width indent -- newstring ) - [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4b80e0818e..4f5bad1aa5 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings assocs combinators io io.streams.string accessors -xml.data wrap xml.entities unicode.categories fry ; +xml.data wrap.strings xml.entities unicode.categories fry ; IN: xml.writer SYMBOL: sensitive-tags From 25d20c6000d36dc0d04c52ad5b2998bb23a1af2b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 8 Feb 2009 23:45:59 -0800 Subject: [PATCH 102/170] Update docs for GENERIC: GENERIC# and HOOK to show stack effect decl --- core/syntax/syntax-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e08821bddd..035622454f 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -551,12 +551,12 @@ HELP: BIN: { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: -{ $syntax "GENERIC: word" } +{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" } { $values { "word" "a new word to define" } } { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ; HELP: GENERIC# -{ $syntax "GENERIC# word n" } +{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" } { $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes @@ -571,7 +571,7 @@ HELP: MATH: { $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ; HELP: HOOK: -{ $syntax "HOOK: word variable" } +{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " } { $values { "word" "a new word to define" } { "variable" word } } { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples From 3bc557467e7b01b472bc4372927634a84489847a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 11:40:05 -0600 Subject: [PATCH 103/170] shuffle( -- ) arbitrary stack shuffling word --- basis/shuffle/shuffle-tests.factor | 2 ++ basis/shuffle/shuffle.factor | 23 +++++++++++++++++++++-- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..8202146b3d 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -3,3 +3,5 @@ USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test + +[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..632c09e338 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,9 +1,28 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generalizations ; - +USING: accessors assocs effects.parser generalizations +hashtables kernel locals locals.backend macros make math +parser sequences ; IN: shuffle +locals-assoc ( sequence -- assoc ) + dup length dup 1- [ - ] curry map zip >hashtable ; + +PRIVATE> + +MACRO: shuffle-effect ( effect -- ) + [ out>> ] [ in>> >locals-assoc ] bi + [ + [ nip assoc-size , \ load-locals , ] + [ [ at , \ get-local , ] curry each ] + [ nip assoc-size , \ drop-locals , ] 2tri + ] [ ] make ; + +: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; parsing + : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : nipd ( a b c -- b c ) rot drop ; inline From 4dd500b5b1ab7d96fb1608f176782a5f57a1abc5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 13:29:50 -0600 Subject: [PATCH 104/170] fortran-invoke works(?) --- basis/alien/fortran/fortran-tests.factor | 98 ++++++------ basis/alien/fortran/fortran.factor | 194 +++++++++++++++-------- 2 files changed, 184 insertions(+), 108 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 0a86cba7e3..9b618ef513 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,7 +1,9 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel macros namespaces sequences -tools.test fry ; +USING: accessors alien alien.c-types alien.complex +alien.fortran alien.strings alien.structs alien.syntax arrays +assocs byte-arrays combinators fry generalizations +io.encodings.ascii kernel macros macros.expander namespaces +sequences shuffle tools.test ; IN: alien.fortran.tests RECORD: FORTRAN_TEST_RECORD @@ -169,17 +171,14 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-invoke - -: fortran-invoke-expansion ( return library function parameters -- quot ) - '[ _ _ _ _ fortran-invoke ] expand-macros ; inline +! (fortran-invoke) [ [ ! [fortran-args>c-args] { [ { [ ascii string>alien ] - [ ] + [ ] [ ] [ ] [ 1 0 ? ] @@ -188,100 +187,109 @@ unit-test } 5 ncleave ! [fortran-invoke] [ - "void" "foopack" "funtimes_" - { "char*" "int*" "float*" "complex-float*" "short*" "long" } + "void" "funpack" "funtimes_" + { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } alien-invoke ] 6 nkeep ! [fortran-results>] + shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) { + [ drop ] [ drop ] [ drop ] [ *float ] [ drop ] [ drop ] - [ drop ] } spread ] ] [ - f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } - fortran-invoke-expansion + f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + (fortran-invoke) ] unit-test [ [ + ! [fortran-args>c-args] + { + [ { [ ] } spread ] + [ { [ drop ] } spread ] + } 1 ncleave ! [fortran-invoke] - "double" "foopack" "fun_times__" - { "float*" } - alien-invoke + [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread ] ] [ - "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" + "void" "funpack" "fun_times__" { "complex-float*" "float*" } alien-invoke ] 2 nkeep ! [fortran-results>] - { - [ *complex-float ] - [ drop ] - } spread + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread ] ] [ - "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] - [ 20 20 ] 1 ndip + [ 20 20 ] 0 ndip ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "float*" } + "void" "funpack" "fun_times__" + { "char*" "long" } alien-invoke - ] 3 nkeep + ] 2 nkeep ! [fortran-results>] - { - [ ] - [ ascii alien>nstring ] - [ drop ] - } spread + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*20" "foopack" "FUN_TIMES" { } - fortran-invoke-expansion + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) ] unit-test [ [ ! [] - [ 10 10 ] 2 ndip + [ 10 10 ] 3 ndip ! [fortran-args>c-args] { [ { [ ascii string>alien ] [ ] + [ ascii string>alien ] } spread ] - [ { [ length ] [ drop ] } spread ] - } 2 ncleave + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "char*" "float*" "long" } + "void" "funpack" "fun_times__" + { "char*" "long" "char*" "float*" "char*" "long" "long" } alien-invoke - ] 5 nkeep + ] 7 nkeep ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) { [ ] [ ascii alien>nstring ] [ ] - [ *float swap ] + [ ascii alien>nstring ] + [ *float ] + [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } - fortran-invoke-expansion + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) ] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index b0bbedd716..85fa0e536e 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,8 +1,11 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.structs alien.syntax -arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals -io.encodings.ascii io.encodings.string ; +USING: accessors alien alien.c-types alien.complex alien.parser +alien.strings alien.structs alien.syntax arrays ascii assocs +byte-arrays combinators combinators.short-circuit fry generalizations +kernel lexer macros math math.parser namespaces parser sequences +splitting stack-checker vectors vocabs.parser words locals +io.encodings.ascii io.encodings.string shuffle effects math.ranges +math.order sorting ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -18,6 +21,8 @@ IN: alien.fortran ERROR: invalid-fortran-type type ; DEFER: fortran-sig>c-sig +DEFER: fortran-ret-type>c-type +DEFER: fortran-arg-type>c-type c-type) M: double-precision-type (fortran-type>c-type) "double" simple-type ; M: double-complex-type (fortran-type>c-type) - "(fortran-double-complex)" simple-type ; + "complex-double" simple-type ; M: misc-type (fortran-type>c-type) dup name>> simple-type ; @@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type) : (parse-fortran-type) ( fortran-type-string -- type ) parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + [ nip new-fortran-type ] [ drop misc-type boa ] if ; : parse-fortran-type ( fortran-type-string/f -- type/f ) dup [ (parse-fortran-type) ] when ; @@ -149,40 +154,49 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) +: args?dims ( type quot -- main-quot added-quot ) + [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline + M: integer-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 1 [ [ ] [ drop ] ] } - { 2 [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: logical-type (fortran-arg>c-args) - call-next-method [ [ 1 0 ? ] prepend ] dip ; + [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ; M: real-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: real-complex-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: double-precision-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: double-complex-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) drop [ ascii string>alien ] [ length ] ; @@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args) M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; -GENERIC: (fortran-result>) ( type -- quot ) +GENERIC: (fortran-result>) ( type -- quots ) + +: result?dims ( type quot -- quot ) + [ dup dims>> [ drop { [ ] } ] ] dip if ; inline M: integer-type (fortran-result>) - size>> { - { f [ [ *int ] ] } - { 1 [ [ *char ] ] } - { 2 [ [ *short ] ] } - { 4 [ [ *int ] ] } - { 8 [ [ *longlong ] ] } + [ size>> { + { f [ { [ *int ] } ] } + { 1 [ { [ *char ] } ] } + { 2 [ { [ *short ] } ] } + { 4 [ { [ *int ] } ] } + { 8 [ { [ *longlong ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: logical-type (fortran-result>) - call-next-method [ zero? not ] append ; + [ call-next-method first [ zero? not ] append 1array ] result?dims ; M: real-type (fortran-result>) - size>> { - { f [ [ *float ] ] } - { 4 [ [ *float ] ] } - { 8 [ [ *double ] ] } + [ size>> { + { f [ { [ *float ] } ] } + { 4 [ { [ *float ] } ] } + { 8 [ { [ *double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: real-complex-type (fortran-result>) - size>> { - { f [ [ *complex-float ] ] } - { 8 [ [ *complex-float ] ] } - { 16 [ [ *complex-double ] ] } + [ size>> { + { f [ { [ *complex-float ] } ] } + { 8 [ { [ *complex-float ] } ] } + { 16 [ { [ *complex-double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: double-precision-type (fortran-result>) - drop [ *double ] ; + [ drop { [ *double ] } ] result?dims ; M: double-complex-type (fortran-result>) - drop [ *complex-double ] ; + [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop [ ascii alien>nstring ] ; + drop { [ ] [ ascii alien>nstring ] } ; M: misc-type (fortran-result>) - drop [ ] ; + drop { [ ] } ; GENERIC: () ( type -- quot ) M: fortran-type () - (fortran-type>c-type) '[ _ ] ; + (fortran-type>c-type) \ [ ] 2sequence ; + +M: character-type () + fix-character-type dims>> product dup + [ \ ] dip [ ] 3sequence ; : [] ( return parameters -- quot ) [ parse-fortran-type ] dip over returns-by-value? [ 2drop [ ] ] - [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + [ [ () ] [ length \ ndip [ ] 3sequence ] bi* ] if ; : [fortran-args>c-args] ( parameters -- quot ) - [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 - [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi - '[ _ _ ncleave ] ; + [ [ ] ] [ + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi + \ ncleave [ ] 3sequence + ] if-empty ; -:: [fortran-invoke] ( return library function parameters -- quot ) +:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) return parameters fortran-sig>c-sig :> c-parameters :> c-return function fortran-name>symbol-name :> c-function - [ c-return library c-function c-parameters alien-invoke ] ; + [args>args] + c-return library c-function c-parameters \ alien-invoke + 5 [ ] nsequence + c-parameters length \ nkeep + [ ] 3sequence ; + +: [fortran-out-param>] ( parameter -- quot ) + parse-fortran-type + [ (fortran-result>) ] [ out?>> ] bi + [ ] [ [ drop [ drop ] ] map ] if ; + +: [fortran-return>] ( return -- quot ) + parse-fortran-type { + { [ dup not ] [ drop { } ] } + { [ dup returns-by-value? ] [ drop { [ ] } ] } + [ (fortran-result>) ] + } cond ; + +: letters ( -- seq ) CHAR: a CHAR: z [a,b] ; + +: (shuffle-map) ( return parameters -- ret par ) + [ + fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + letters swap head [ "ret" swap suffix ] map + ] [ + [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ first2 letters swap head [ "" 2sequence ] with map ] map concat + ] bi* ; + +: (fortran-in-shuffle) ( ret par -- seq ) + [ [ second ] bi@ <=> ] sort append ; + +: (fortran-out-shuffle) ( ret par -- seq ) + append ; + +: [fortran-result-shuffle] ( return parameters -- quot ) + (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi + \ shuffle-effect [ ] 2sequence ; : [fortran-results>] ( return parameters -- quot ) - 2drop [ ] ; + [ [fortran-result-shuffle] ] + [ drop [fortran-return>] ] + [ nip [ [fortran-out-param>] ] map concat ] 2tri + append + \ spread [ ] 2sequence append ; PRIVATE> @@ -289,22 +353,26 @@ PRIVATE> : RECORD: scan in get parse-definition define-fortran-record ; parsing -MACRO: fortran-invoke ( return library function parameters -- ) +: (fortran-invoke) ( return library function parameters -- quot ) { [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] [ 2nip [fortran-results>] ] - } 4 ncleave 3append ; + } 4 ncleave 4 nappend ; + +MACRO: fortran-invoke ( return library function parameters -- ) + (fortran-invoke) ; :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic return library function parameters return parse-arglist - [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; + [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: f "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing + : FUNCTION: scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing From 0522f63e5fe9154bbfada242e65f14f262650c9e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:29 -0600 Subject: [PATCH 105/170] alien.fortran metadata --- basis/alien/fortran/authors.txt | 1 + basis/alien/fortran/summary.txt | 1 + basis/alien/fortran/tags.txt | 2 ++ 3 files changed, 4 insertions(+) create mode 100644 basis/alien/fortran/authors.txt create mode 100644 basis/alien/fortran/summary.txt create mode 100644 basis/alien/fortran/tags.txt diff --git a/basis/alien/fortran/authors.txt b/basis/alien/fortran/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/alien/fortran/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt new file mode 100644 index 0000000000..8ed8b0ca00 --- /dev/null +++ b/basis/alien/fortran/summary.txt @@ -0,0 +1 @@ +GNU Fortran/G77/F2C alien interface diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt new file mode 100644 index 0000000000..2a9b5def7a --- /dev/null +++ b/basis/alien/fortran/tags.txt @@ -0,0 +1,2 @@ +fortran +ffi From 3b83d9f760304b55617f7664db5d795fdcce34dc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:52 -0600 Subject: [PATCH 106/170] fortran ffi for blas --- basis/math/blas/ffi/authors.txt | 1 + basis/math/blas/ffi/ffi.factor | 528 ++++++++++++++++++++++++++++++++ basis/math/blas/ffi/summary.txt | 1 + basis/math/blas/ffi/tags.txt | 3 + 4 files changed, 533 insertions(+) create mode 100644 basis/math/blas/ffi/authors.txt create mode 100644 basis/math/blas/ffi/ffi.factor create mode 100644 basis/math/blas/ffi/summary.txt create mode 100644 basis/math/blas/ffi/tags.txt diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/blas/ffi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor new file mode 100644 index 0000000000..7b0138357a --- /dev/null +++ b/basis/math/blas/ffi/ffi.factor @@ -0,0 +1,528 @@ +USING: alien alien.fortran kernel system combinators ; +IN: math.blas.ffi + +<< +"blas" { + { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } + [ "libblas.so" "cdecl" add-library ] +} cond +>> + +LIBRARY: blas + +! Level 1 BLAS (scalar-vector and vector-vector) + +FUNCTION: REAL SDSDOT + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DSDOT + ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: REAL SDOT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DDOT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +FUNCTION: COMPLEX CDOTU + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +FUNCTION: COMPLEX CDOTC + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DOUBLE-COMPLEX ZDOTU + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: DOUBLE-COMPLEX ZDOTC + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +FUNCTION: REAL SNRM2 + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: REAL SASUM + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DNRM2 + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DASUM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +FUNCTION: REAL SCNRM2 + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: REAL SCASUM + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DZNRM2 + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DZASUM + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: INTEGER ISAMAX + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IDAMAX + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER ICAMAX + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IZAMAX + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SSWAP + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SCOPY + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SAXPY + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DSWAP + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DCOPY + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DAXPY + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +SUBROUTINE: CSWAP + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CCOPY + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CAXPY + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: ZSWAP + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZCOPY + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZAXPY + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: SSCAL + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: DSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: CSCAL + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZSCAL + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CSSCAL + ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZDSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SROTG + ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ; +SUBROUTINE: SROTMG + ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ; +SUBROUTINE: SROT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ; +SUBROUTINE: SROTM + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ; + +SUBROUTINE: DROTG + ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ; +SUBROUTINE: DROTMG + ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ; +SUBROUTINE: DROT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ; +SUBROUTINE: DROTM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ; + +! LEVEL 2 BLAS (MATRIX-VECTOR) + +SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX, REAL BETA, + REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, REAL ALPHA, + REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: STRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX ) ; +SUBROUTINE: STBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; + +SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, + DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX ) ; +SUBROUTINE: DTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, + COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, COMPLEX ALPHA, + COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: CTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, + DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + + +SUBROUTINE: SSYMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSPMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) AP, + REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGER ( INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) X, INTEGER INCX, + REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSYR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) AP ) ; +SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A, + INTEGER LDA ) ; +SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ; + +SUBROUTINE: DSYMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP, + DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGER ( INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSYR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSPR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) AP ) ; +SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, + INTEGER LDA ) ; +SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ; + + +SUBROUTINE: CHEMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHPMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP, + COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGERU ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CGERC ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, + INTEGER INCX, COMPLEX(*) A ) ; +SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ; + +SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP, + DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGERU ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZGERC ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX(*) A ) ; +SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ; + +! LEVEL 3 BLAS (MATRIX-MATRIX) + +SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) B, INTEGER LDB, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: STRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; +SUBROUTINE: STRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; + +SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; +SUBROUTINE: DTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; + +SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) B, INTEGER LDB, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: CTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: CHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, COMPLEX(*) A, INTEGER LDA, + REAL BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, REAL BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt new file mode 100644 index 0000000000..8c0106b173 --- /dev/null +++ b/basis/math/blas/ffi/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt new file mode 100644 index 0000000000..f468a9989d --- /dev/null +++ b/basis/math/blas/ffi/tags.txt @@ -0,0 +1,3 @@ +math +bindings +fortran From 35b526cc7a034fb945342ab53c247a04abc4791c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:29:09 -0600 Subject: [PATCH 107/170] Docs for lists, consolidating list functionality in lists, minor API changes --- basis/lists/lazy/lazy.factor | 4 +- basis/lists/lists-docs.factor | 133 ++++++++++++++---- basis/lists/lists-tests.factor | 20 +-- basis/lists/lists.factor | 123 ++++++++++------ basis/persistent/deques/deques-docs.factor | 2 + basis/persistent/deques/deques.factor | 47 +++---- basis/urls/urls-docs.factor | 4 +- basis/wrap/wrap.factor | 14 +- core/math/math-docs.factor | 2 +- .../parser-combinators.factor | 2 +- extra/project-euler/134/134.factor | 2 +- 11 files changed, 221 insertions(+), 132 deletions(-) diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 213285e643..5adb7a8be5 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -125,7 +125,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call( elt -- ? ) + [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -284,7 +284,7 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons swap (lconcat) + uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8807c8cf8a..8494d7c352 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -1,15 +1,68 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel help.markup help.syntax ; - +USING: kernel help.markup help.syntax arrays sequences math quotations ; IN: lists -{ car cons cdr nil nil? list? uncons } related-words +ABOUT: "lists" + +ARTICLE: "lists" "Lists" +"The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well." +{ $subsection { "lists" "protocol" } } +{ $subsection { "lists" "strict" } } +{ $subsection { "lists" "manipulation" } } +{ $subsection { "lists" "combinators" } } +{ $vocab-subsection "Lazy lists" "lists.lazy" } ; + +ARTICLE: { "lists" "protocol" } "The list protocol" +"Lists are instances of a mixin class" +{ $subsection list } +"Instances of the mixin must implement the following words:" +{ $subsection car } +{ $subsection cdr } +{ $subsection nil? } ; + +ARTICLE: { "lists" "strict" } "Strict lists" +"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" +{ $subsection cons } +{ $subsection swons } +{ $subsection sequence>cons } +{ $subsection deep-sequence>cons } +{ $subsection 1list } +{ $subsection 2list } +{ $subsection 3list } ; + +ARTICLE: { "lists" "combinators" } "Combinators for lists" +"Several combinators exist for list traversal." +{ $subsection leach } +{ $subsection lmap } +{ $subsection foldl } +{ $subsection foldr } +{ $subsection lmap>array } +{ $subsection lmap-as } +{ $subsection traverse } ; + +ARTICLE: { "lists" "manipulation" } "Manipulating lists" +"To get at the contents of a list:" +{ $subsection uncons } +{ $subsection unswons } +{ $subsection lnth } +{ $subsection cadr } +{ $subsection llength } +"To get a new list from an old one:" +{ $subsection lreverse } +{ $subsection lappend } +{ $subsection lcut } ; HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } } { $description "Constructs a cons cell." } ; +HELP: swons +{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +{ cons swons uncons unswons } related-words + HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } { $description "Returns the first item in the list." } ; @@ -17,7 +70,9 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + +{ car cdr } related-words + HELP: nil { $values { "symbol" "The empty cons (+nil+)" } } { $description "Returns a symbol representing the empty list" } ; @@ -26,6 +81,8 @@ HELP: nil? { $values { "object" object } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; +{ nil nil? } related-words + HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -43,7 +100,7 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } { $description "Create a list with 3 elements." } ; - + HELP: lnth { $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } { $description "Outputs the nth element of the list." } @@ -55,7 +112,11 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: unswons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words @@ -75,30 +136,52 @@ HELP: foldr HELP: lmap { $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; - + HELP: lreverse -{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } -{ $description "Reverses the input list, outputing a new, reversed list" } ; - -HELP: list>seq -{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $values { "list" list } { "newlist" list } } +{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ; + +HELP: list>array +{ $values { "list" "a cons object" } { "array" array } } { $description "Turns the given cons object into an array, maintaing order." } ; - -HELP: seq>list -{ $values { "seq" "a sequence" } { "list" "a cons object" } } + +HELP: sequence>cons +{ $values { "sequence" sequence } { "list" cons } } { $description "Turns the given array into a cons object, maintaing order." } ; - -HELP: cons>seq -{ $values { "cons" "a cons object" } { "array" "an array object" } } + +HELP: deep-list>array +{ $values { "list" list } { "array" array } } { $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; - -HELP: seq>cons -{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } + +HELP: deep-sequence>cons +{ $values { "sequence" sequence } { "cons" cons } } { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; - + HELP: traverse { $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" - " returns true for with the result of applying quot to." } ; - + " returns true for with the result of applying quot to." } ; + +HELP: list +{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ; + +HELP: cadr +{ $values { "list" list } { "elt" object } } +{ $description "Returns the second element of the list, ie the car of the cdr." } ; + +HELP: lappend +{ $values { "list1" list } { "list2" list } { "newlist" list } } +{ $description "Appends the two lists to form a new list. The first list must be finite. The result is a strict cons cell, and the first list is exausted." } ; + +HELP: lcut +{ $values { "list" list } { "index" integer } { "before" cons } { "after" cons } } +{ $description "Analogous to " { $link cut } ", this word cuts a list into two pieces at the given index." } ; + +HELP: lmap>array +{ $values { "list" list } { "quot" quotation } { "array" array } } +{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ; + +HELP: lmap-as +{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } } +{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 4a08a4d1e3..404a776505 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -5,7 +5,7 @@ USING: tools.test lists math ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq + { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -38,33 +38,33 @@ IN: lists.tests +nil+ } } } +nil+ } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons + { 1 2 { 3 4 { 5 } } } deep-sequence>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } seq>cons [ 1+ ] lmap + { 1 2 3 4 } sequence>cons [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>seq + { 1 2 3 4 5 } sequence>cons lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>cons llength ] unit-test { { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq -] unit-test \ No newline at end of file + { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array +] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 5568b9d53e..784bc95bfe 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words locals ; +USING: kernel sequences accessors math arrays vectors classes words +combinators.short-circuit combinators ; IN: lists ! List Protocol MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( object -- ? ) +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( object -- ? ) -TUPLE: cons car cdr ; +TUPLE: cons { car read-only } { cdr read-only } ; C: cons cons @@ -18,41 +19,53 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; - -SYMBOL: +nil+ -M: word nil? +nil+ eq? ; + +SINGLETON: +nil+ +M: +nil+ nil? drop t ; M: object nil? drop f ; - -: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; + +: atom? ( obj -- ? ) + { [ list? ] [ nil? ] } 1|| not ; : nil ( -- symbol ) +nil+ ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - + +: uncons ( cons -- car cdr ) + [ car ] [ cdr ] bi ; + +: swons ( cdr car -- cons ) + swap cons ; + +: unswons ( cons -- cdr car ) + uncons swap ; + : 1list ( obj -- cons ) nil cons ; - + +: 1list? ( list -- ? ) + { [ nil? not ] [ cdr nil? ] } 1&& ; + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; - -: cadr ( cons -- elt ) + +: cadr ( list -- elt ) cdr car ; - -: 2car ( cons -- car caar ) + +: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; - -: 3car ( cons -- car cadr caddr ) + +: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - + + : leach ( list quot: ( elt -- ) -- ) over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive @@ -71,41 +84,59 @@ M: object nil? drop f ; : llength ( list -- n ) 0 [ drop 1+ ] foldl ; - + : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; - + : lappend ( list1 list2 -- newlist ) [ lreverse ] dip [ swap cons ] foldl ; - -: seq>list ( seq -- list ) + +: lcut ( list index -- before after ) + [ +nil+ ] dip + [ [ [ cdr ] [ car ] bi ] dip cons ] times + lreverse swap ; + +: sequence>cons ( sequence -- list ) nil [ swap cons ] reduce ; - + +cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - +PRIVATE> + +: deep-sequence>cons ( sequence -- cons ) + [ ] keep nil + [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + +array) ( acc cons quot: ( elt -- elt' ) -- newcons ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; + [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline recursive - -: lmap>array ( cons quot -- newcons ) - { } -rot (lmap>array) ; inline - -: lmap-as ( cons quot exemplar -- seq ) +PRIVATE> + +: lmap>array ( list quot -- array ) + [ { } ] 2dip (lmap>array) ; inline + +: lmap-as ( list quot exemplar -- sequence ) [ lmap>array ] dip like ; - -: cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ; - -: list>seq ( list -- array ) + +: deep-list>array ( list -- array ) + [ + { + { [ dup list? ] [ deep-list>array ] } + { [ dup nil? ] [ drop { } ] } + [ ] + } cond + ] lmap>array ; + +: list>array ( list -- array ) [ ] lmap>array ; - + : traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive - + [ + 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if + ] 2curry lmap ; inline recursive + INSTANCE: cons list diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index 43018bed16..f1027d107b 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences ; IN: persistent.deques diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index ece1cda772..8f93ae1ab8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,7 +1,6 @@ -! Copyback (C) 2008 Daniel Ehrenberg +! Copyright (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math lists ; -QUALIFIED: sequences +USING: kernel accessors math lists sequences combinators.short-circuit ; IN: persistent.deques ! Amortized O(1) push/pop on both ends for single-threaded access @@ -9,30 +8,13 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. TUPLE: deque { front read-only } { back read-only } ; -: ( -- deque ) T{ deque } ; +: ( -- deque ) + T{ deque f +nil+ +nil+ } ; : deque-empty? ( deque -- ? ) - [ front>> ] [ back>> ] bi or not ; + { [ front>> nil? ] [ back>> nil? ] } 1&& ; [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) - back>> [ split-reverse deque boa remove ] - [ "Popping from an empty deque" throw ] if* ; inline + back>> dup nil? + [ "Popping from an empty deque" throw ] + [ split-reverse deque boa remove ] if ; inline : pop ( deque -- item newdeque ) - dup front>> [ remove ] [ transfer ] if ; inline + dup front>> nil? [ transfer ] [ remove ] if ; inline PRIVATE> : pop-front ( deque -- item newdeque ) @@ -74,12 +57,14 @@ PRIVATE> : pop-back ( deque -- item newdeque ) [ pop ] flipped ; -: peek-front ( deque -- item ) pop-front drop ; +: peek-front ( deque -- item ) + pop-front drop ; -: peek-back ( deque -- item ) pop-back drop ; +: peek-back ( deque -- item ) + pop-back drop ; : sequence>deque ( sequence -- deque ) - [ push-back ] sequences:reduce ; + [ push-back ] reduce ; : deque>sequence ( deque -- sequence ) - [ dup deque-empty? not ] [ pop-front swap ] [ ] sequences:produce nip ; + [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index f6c25980ea..437a9419e3 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,8 +82,8 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls ;" - "\"sbcl.org:80\" parse-host .s" + "USING: prettyprint urls kernel ;" + "\"sbcl.org:80\" parse-host .s 2drop" "\"sbcl.org\"\n80" } } ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 55fe10283a..6e5bf31075 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -12,18 +12,6 @@ C: element : element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -: swons ( cdr car -- cons ) - swap cons ; - -: unswons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - -: 1list? ( list -- ? ) - { [ ] [ cdr +nil+ = ] } 1&& ; - -: lists>arrays ( lists -- arrays ) - [ list>seq ] lmap>array ; - TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -78,7 +66,7 @@ SYMBOL: line-ideal 0 ; : post-process ( paragraph -- array ) - lines>> lists>arrays + lines>> deep-list>array [ [ contents>> ] map ] map ; : initialize ( elements -- elements paragraph ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 7d0666328f..94ff2c1f29 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -254,7 +254,7 @@ HELP: fp-infinity? { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } { $examples { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } - { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; { fp-nan? fp-infinity? } related-words diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 8afbb2d03b..347ab638ff 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -17,7 +17,7 @@ ERROR: cannot-parse input ; : parse-1 ( input parser -- result ) dupd parse dup nil? [ - rot cannot-parse + swap cannot-parse ] [ nip car parsed>> ] if ; diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index e00e86865d..0f009919d9 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons swap [ 1000000 > ] luntil + 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time From 42265cbc62fbb50ee8b8a201603fb78624678160 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:35:44 -0600 Subject: [PATCH 108/170] start hacking on math.blas.vectors to switch to fortran --- basis/alien/fortran/fortran.factor | 10 ++++++++++ basis/math/blas/vectors/vectors.factor | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 85fa0e536e..00dd8583fc 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -11,6 +11,14 @@ IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes +<< +: add-f2c-libraries ( -- ) + "I77" "libI77.so" "cdecl" add-library + "F77" "libF77.so" "cdecl" add-library ; + +os netbsd? [ add-f2c-libraries ] when +>> + : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; @@ -377,3 +385,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing +: LIBRARY: + scan "c-library" set ; parsing diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 4e61f4478e..d111023456 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,10 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.cblas +combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double -specialized-arrays.direct.float specialized-arrays.direct.double ; +specialized-arrays.direct.float specialized-arrays.direct.double +specialized-arrays.complex-float specialized-arrays.complex-double +specialized-arrays.direct.complex-float +specialized-arrays.direct.complex-double ; IN: math.blas.vectors TUPLE: blas-vector-base underlying length inc ; @@ -130,9 +133,9 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- ) IS >ARRAY IS >${TYPE}-array -XCOPY IS cblas_${T}copy -XSWAP IS cblas_${T}swap -IXAMAX IS cblas_i${T}amax +XCOPY IS ${T}COPY +XSWAP IS ${T}SWAP +IXAMAX IS I${T}AMAX VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> @@ -264,16 +267,14 @@ M: VECTOR n*V! : define-real-blas-vector ( TYPE T -- ) [ (define-blas-vector) ] [ (define-real-blas-vector) ] 2bi ; -:: define-complex-blas-vector ( TYPE C S -- ) - TYPE (define-complex-helpers) - TYPE "-complex" append - [ C (define-blas-vector) ] - [ C S (define-complex-blas-vector) ] bi ; +: define-complex-blas-vector ( TYPE C S -- ) + [ drop (define-blas-vector) ] + [ (define-complex-blas-vector) ] 3bi ; "float" "s" define-real-blas-vector "double" "d" define-real-blas-vector -"float" "c" "s" define-complex-blas-vector -"double" "z" "d" define-complex-blas-vector +"complex-float" "c" "s" define-complex-blas-vector +"complex-double" "z" "d" define-complex-blas-vector >> From 975f197558c5efc49e43c87477b50bcaea64d962 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:37:22 -0600 Subject: [PATCH 109/170] Fixing help-lint bugs --- .../generalizations-docs.factor | 20 +++++++++---------- core/kernel/kernel-docs.factor | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index ac8e14c05a..376ae5bed2 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 71183093ee..b8191004db 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -658,7 +658,7 @@ HELP: loop "hi hi hi" } "A fun loop:" { $example "USING: kernel prettyprint math ; " - "3 [ dup . 7 + 11 mod dup 3 = not ] loop" + "3 [ dup . 7 + 11 mod dup 3 = not ] loop drop" "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } } ; From 32481f8e2f2909a50788532c58f8d9deff479ed9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:01:41 -0600 Subject: [PATCH 110/170] my stuped, let me show u it --- basis/alien/complex/functor/functor.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index c6644eba1d..31af0291b4 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -28,8 +28,8 @@ T in get define-struct T c-type - 1quotation >>boxer-quot -*T 1quotation >>unboxer-quot + 1quotation >>unboxer-quot +*T 1quotation >>boxer-quot drop ;FUNCTOR From d24b03098a58526dc43c2cb11142498ef512ed84 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:11:27 -0600 Subject: [PATCH 111/170] specialized arrays for complex types --- basis/specialized-arrays/complex-double/complex-double.factor | 4 ++++ basis/specialized-arrays/complex-float/complex-float.factor | 4 ++++ .../direct/complex-double/complex-double.factor | 4 ++++ .../direct/complex-float/complex-float.factor | 4 ++++ 4 files changed, 16 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/complex-float/complex-float.factor create mode 100644 basis/specialized-arrays/direct/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/direct/complex-float/complex-float.factor diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor new file mode 100644 index 0000000000..00b07fb9b3 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-double + +<< "complex-double" define-array >> diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor new file mode 100644 index 0000000000..5348343bae --- /dev/null +++ b/basis/specialized-arrays/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-float + +<< "complex-float" define-array >> diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor new file mode 100644 index 0000000000..58af77b0c0 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-double + +<< "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor new file mode 100644 index 0000000000..d881c1e0d4 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-float + +<< "complex-float" define-direct-array >> From 462b208475382fc240648a92a296c95be90d8520 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 15:31:57 -0600 Subject: [PATCH 112/170] Cleaning up strict list combinators --- basis/lists/lists-tests.factor | 5 ++-- basis/lists/lists.factor | 47 +++++++++++++++++++--------------- basis/wrap/words/words.factor | 2 +- 3 files changed, 30 insertions(+), 24 deletions(-) diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 404a776505..13d2e03e0f 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math ; - +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ @@ -68,3 +67,5 @@ IN: lists.tests { { 1 2 3 4 5 6 } } [ { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array ] unit-test + +[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 784bc95bfe..4b0abb7f2d 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words -combinators.short-circuit combinators ; +combinators.short-circuit combinators locals ; IN: lists ! List Protocol @@ -25,7 +25,7 @@ M: +nil+ nil? drop t ; M: object nil? drop f ; : atom? ( obj -- ? ) - { [ list? ] [ nil? ] } 1|| not ; + list? not ; : nil ( -- symbol ) +nil+ ; @@ -76,10 +76,10 @@ PRIVATE> : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) swapd leach ; inline -: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) - pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ - [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi - call +:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) + list nil? [ identity ] [ + list cdr identity quot foldr + list car quot call ] if ; inline recursive : llength ( list -- n ) @@ -92,7 +92,7 @@ PRIVATE> [ lreverse ] dip [ swap cons ] foldl ; : lcut ( list index -- before after ) - [ +nil+ ] dip + [ nil ] dip [ [ [ cdr ] [ car ] bi ] dip cons ] times lreverse swap ; @@ -109,23 +109,27 @@ PRIVATE> [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; array) ( acc cons quot: ( elt -- elt' ) -- newcons ) - over nil? [ 2drop ] - [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; - inline recursive +:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc ) + list nil? [ acc ] [ + list car quot call acc push + acc list cdr quot (lmap>vector) + ] if ; inline recursive + +: lmap>vector ( list quot -- array ) + [ V{ } clone ] 2dip (lmap>vector) ; inline PRIVATE> -: lmap>array ( list quot -- array ) - [ { } ] 2dip (lmap>array) ; inline - : lmap-as ( list quot exemplar -- sequence ) - [ lmap>array ] dip like ; + [ lmap>vector ] dip like ; inline + +: lmap>array ( list quot -- array ) + { } lmap-as ; inline : deep-list>array ( list -- array ) [ { - { [ dup list? ] [ deep-list>array ] } { [ dup nil? ] [ drop { } ] } + { [ dup list? ] [ deep-list>array ] } [ ] } cond ] lmap>array ; @@ -133,10 +137,11 @@ PRIVATE> : list>array ( list -- array ) [ ] lmap>array ; -: traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ - 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if - ] 2curry lmap ; inline recursive +:: traverse ( list pred quot: ( list/elt -- result ) -- result ) + list [| elt | + elt dup pred call [ quot call ] when + dup list? [ pred quot traverse ] when + ] lmap ; inline recursive INSTANCE: cons list +INSTANCE: +nil+ list diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index 00f257a5cf..bcf4460170 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel splitting.monotonic accessors wrap grouping ; +USING: sequences kernel splitting.monotonic accessors grouping wrap ; IN: wrap.words TUPLE: word key width break? ; From db6706434d711e5313ca1618302a8f83c9c3d817 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:38:07 -0600 Subject: [PATCH 113/170] tweak specialized-arrays to box values returned by nth --- basis/alien/c-types/c-types.factor | 3 +++ basis/alien/structs/fields/fields.factor | 5 +---- basis/specialized-arrays/direct/functor/functor.factor | 2 +- basis/specialized-arrays/functor/functor.factor | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 89b3572daf..a4bc3d3f52 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -185,6 +185,9 @@ M: f byte-length drop 0 ; [ "Cannot read struct fields with this type" throw ] ] unless* ; +: c-type-getter-boxer ( name -- quot ) + [ c-getter ] [ c-type-boxer-quot ] bi append ; + : c-setter ( name -- quot ) c-type-setter [ [ "Cannot write struct fields with this type" throw ] diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index f5537fa239..0477683442 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ reader>> ] - [ - type>> - [ c-getter ] [ c-type-boxer-quot ] bi append - ] + [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 0c3999db44..e7e891fede 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -14,7 +14,7 @@ A' IS ${T}-array A DEFINES-CLASS direct-${T}-array DEFINES <${A}> -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3c2c53db31..09433a3b51 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -22,7 +22,7 @@ A DEFINES-CLASS ${T}-array byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE From 85620fc74118037dd35e908bd210e74ec03ea173 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:47 -0600 Subject: [PATCH 114/170] C CONVERT VECTORS TO USE FORTRAN BLAS BINDINGS C INSTEAD OF CBLAS --- basis/math/blas/vectors/vectors.factor | 83 ++++++++------------------ 1 file changed, 25 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d111023456..9a2f9a4350 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,4 +1,4 @@ -USING: accessors alien alien.c-types arrays byte-arrays combinators +USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private @@ -141,7 +141,12 @@ VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector -XVECTOR{ DEFINES ${T}vector{ +t [ T >lower ] + +XVECTOR{ DEFINES ${t}vector{ + +XAXPY IS ${T}AXPY +XSCAL IS ${T}SCAL WHERE @@ -170,6 +175,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +M: VECTOR n*V+V! + (prepare-axpy) [ XAXPY ] dip ; +M: VECTOR n*V! + (prepare-scal) [ XSCAL ] dip ; + : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing M: VECTOR pprint-delims @@ -181,11 +191,9 @@ M: VECTOR pprint-delims FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) VECTOR IS ${TYPE}-blas-vector -XDOT IS cblas_${T}dot -XNRM2 IS cblas_${T}nrm2 -XASUM IS cblas_${T}asum -XAXPY IS cblas_${T}axpy -XSCAL IS cblas_${T}scal +XDOT IS ${T}DOT +XNRM2 IS ${T}NRM2 +XASUM IS ${T}ASUM WHERE @@ -197,33 +205,6 @@ M: VECTOR Vnorm (prepare-nrm2) XNRM2 ; M: VECTOR Vasum (prepare-nrm2) XASUM ; -M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - (prepare-scal) [ XSCAL ] dip ; - -;FUNCTOR - - -FUNCTOR: (define-complex-helpers) ( TYPE -- ) - - DEFINES ->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array -ARG>COMPLEX DEFINES arg>${TYPE}-complex -COMPLEX>ARG DEFINES ${TYPE}-complex>arg - IS ->ARRAY IS >${TYPE}-array - -WHERE - -: ( alien len -- sequence ) - 1 shift ; -: >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY ; -: COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY underlying>> ; -: ARG>COMPLEX ( alien -- complex ) - 2 first2 rect> ; ;FUNCTOR @@ -231,35 +212,21 @@ WHERE FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) VECTOR IS ${TYPE}-blas-vector -XDOTU_SUB IS cblas_${C}dotu_sub -XDOTC_SUB IS cblas_${C}dotc_sub -XXNRM2 IS cblas_${S}${C}nrm2 -XXASUM IS cblas_${S}${C}asum -XAXPY IS cblas_${C}axpy -XSCAL IS cblas_${C}scal -TYPE>ARG IS ${TYPE}>arg -ARG>TYPE IS arg>${TYPE} +XDOTU IS ${C}DOTU +XDOTC IS ${C}DOTC +XXNRM2 IS ${S}${C}NRM2 +XXASUM IS ${S}${C}ASUM WHERE M: VECTOR V. - (prepare-dot) TYPE - [ XDOTU_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTU ; M: VECTOR V.conj - (prepare-dot) TYPE - [ XDOTC_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTC ; M: VECTOR Vnorm (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum (prepare-nrm2) XXASUM ; -M: VECTOR n*V+V! - [ TYPE>ARG ] 2dip - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - [ TYPE>ARG ] dip - (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -271,10 +238,10 @@ M: VECTOR n*V! [ drop (define-blas-vector) ] [ (define-complex-blas-vector) ] 3bi ; -"float" "s" define-real-blas-vector -"double" "d" define-real-blas-vector -"complex-float" "c" "s" define-complex-blas-vector -"complex-double" "z" "d" define-complex-blas-vector +"float" "S" define-real-blas-vector +"double" "D" define-real-blas-vector +"complex-float" "C" "S" define-complex-blas-vector +"complex-double" "Z" "D" define-complex-blas-vector >> From 08b02fadc9ea836e6fb65da5da841ac1ce236fb6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:59 -0600 Subject: [PATCH 115/170] typos --- basis/alien/fortran/fortran.factor | 2 +- basis/math/blas/ffi/ffi.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 00dd8583fc..c7688fbe3a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,7 +5,7 @@ byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges -math.order sorting ; +math.order sorting system ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7b0138357a..03043e54ed 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -27,9 +27,9 @@ FUNCTION: COMPLEX CDOTU FUNCTION: COMPLEX CDOTC ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTU +FUNCTION: DOUBLE-COMPLEX ZDOTU ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTC +FUNCTION: DOUBLE-COMPLEX ZDOTC ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; FUNCTION: REAL SNRM2 From 0c589061ad895c6a3e8d1914ddc29cd49659cdbf Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:18:24 -0600 Subject: [PATCH 116/170] More docs for lazy lists, getting rid of lazy-map-with --- basis/lists/lazy/lazy-docs.factor | 55 ++++++++++++++++--- basis/lists/lazy/lazy-tests.factor | 2 +- basis/lists/lazy/lazy.factor | 7 +-- .../parser-combinators.factor | 8 +-- 4 files changed, 54 insertions(+), 18 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index c402cdf15b..08fe3bbcba 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,11 +1,54 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. - USING: help.markup help.syntax sequences strings lists ; IN: lists.lazy +ABOUT: "lists.lazy" + +ARTICLE: "lists.lazy" "Lazy lists" +"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them." +{ $subsection { "lists.lazy" "construction" } } +{ $subsection { "lists.lazy" "manipulation" } } +{ $subsection { "lists.lazy" "combinators" } } +{ $subsection { "lists.lazy" "io" } } ; + +ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" +"The following combinators create lazy lists from other lazy lists:" +{ $subsection lmap } +{ $subsection lfilter } +{ $subsection luntil } +{ $subsection lwhile } +{ $subsection lfrom-by } +{ $subsection lcomp } +{ $subsection lcomp* } ; + +ARTICLE: { "lists.lazy" "io" } "Lazy list I/O" +"Input from a stream can be read through a lazy list, using the following words:" +{ $subsection lcontents } +{ $subsection llines } ; + +ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" +"Words for constructing lazy lists:" +{ $subsection lazy-cons } +{ $subsection 1lazy-list } +{ $subsection 2lazy-list } +{ $subsection 3lazy-list } +{ $subsection seq>list } +{ $subsection >list } +{ $subsection lfrom } ; + +ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" +"To make new lazy lists from old ones:" +{ $subsection } +{ $subsection lappend } +{ $subsection lconcat } +{ $subsection lcartesian-product } +{ $subsection lcartesian-product* } +{ $subsection lmerge } +{ $subsection ltake } ; + HELP: lazy-cons -{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } +{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; @@ -28,16 +71,12 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lazy-map-with -{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; - HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; @@ -86,7 +125,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 03221841c1..f4e55cba19 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -24,7 +24,7 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lazy-map-with list>array + 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test [ [ ] lmap ] must-infer diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 5adb7a8be5..d3b08a11fb 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lazy-map-with ( value list quot -- result ) - with lazy-map ; - TUPLE: lazy-take n cons ; C: lazy-take @@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; + swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat + swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 347ab638ff..99e8099f38 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -149,8 +149,8 @@ TUPLE: and-parser parsers ; [ parsed>> ] dip [ parsed>> 2array ] keep unparsed>> - ] lazy-map-with - ] lazy-map-with lconcat ; + ] with lazy-map + ] with lazy-map lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. parsers>> 0 swap seq>list - [ parse ] lazy-map-with lconcat ; + [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parsed>> swap call ] keep unparsed>> - ] lazy-map-with ; + ] with lazy-map ; TUPLE: some-parser p1 ; From d45f0c83eb94675ac655a15ebb93c7fa5335f2f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:09 -0600 Subject: [PATCH 117/170] more work on tiff files. --- extra/graphics/tiff/tiff-tests.factor | 4 +- extra/graphics/tiff/tiff.factor | 174 ++++++++++++++++++++++---- 2 files changed, 151 insertions(+), 27 deletions(-) diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor index daee9a5d9e..f800b4d213 100755 --- a/extra/graphics/tiff/tiff-tests.factor +++ b/extra/graphics/tiff/tiff-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Your name. +! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test graphics.tiff ; IN: graphics.tiff.tests @@ -6,4 +6,6 @@ IN: graphics.tiff.tests : tiff-test-path ( -- path ) "resource:extra/graphics/tiff/rgb.tiff" ; +: tiff-test-path2 ( -- path ) + "resource:extra/graphics/tiff/octagon.tiff" ; diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index f0b3f9337e..9461403805 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes ; +sorting.slots math.order math.parser prettyprint classes +io.binary assocs math math.bitwise byte-arrays grouping ; +USE: multiline + IN: graphics.tiff TUPLE: tiff @@ -14,13 +17,14 @@ ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next processed-tags strips ; +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; -TUPLE: ifd-entry tag type count offset ; +TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; TUPLE: photometric-interpretation color ; @@ -132,6 +136,44 @@ ERROR: bad-planar-configuration n ; [ bad-predictor ] } case ; +TUPLE: sample-format n ; +CONSTRUCTOR: sample-format ( n -- object ) ; +ERROR: bad-sample-format n ; + +SINGLETONS: sample-unsigned-integer sample-signed-integer +sample-ieee-float sample-undefined-data ; + +: lookup-sample-format ( seq -- object ) + [ + { + { 1 [ sample-unsigned-integer ] } + { 2 [ sample-signed-integer ] } + { 3 [ sample-ieee-float ] } + { 4 [ sample-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + + +TUPLE: extra-samples n ; +CONSTRUCTOR: extra-samples ( n -- object ) ; +ERROR: bad-extra-samples n ; + +SINGLETONS: unspecified-alpha-data associated-alpha-data +unassociated-alpha-data ; + +: lookup-extra-samples ( seq -- object ) + { + { 0 [ unspecified-alpha-data ] } + { 1 [ associated-alpha-data ] } + { 2 [ unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + + +TUPLE: orientation n ; +CONSTRUCTOR: orientation ( n -- object ) ; + TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; @@ -157,6 +199,7 @@ ERROR: bad-tiff-magic bytes ; : push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + ! over [ dup class ] [ ifds>> ] bi* set-at ; : read-ifd ( -- ifd ) 2 read endian> @@ -165,29 +208,96 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> ; : read-ifds ( tiff -- tiff ) - [ - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi - ] with-tiff-endianness ; + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> + ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) - dup processed-tags>> - [ [ strip-byte-counts instance? ] find nip n>> ] - [ [ strip-offsets instance? ] find nip n>> ] bi - [ seek-absolute seek-input read ] { } 2map-as >>strips ; + dup + [ strip-byte-counts find-tag n>> ] + [ strip-offsets find-tag n>> ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + : ifd-entry-value ( ifd-entry -- n ) - dup count>> 1 = [ - offset>> + dup value-length 4 <= [ + adjust-offset/value ] [ - [ offset>> seek-absolute seek-input ] [ count>> read ] bi + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj ] if ; : process-ifd-entry ( ifd-entry -- object ) @@ -199,6 +309,7 @@ ERROR: bad-tiff-magic bytes ; { 259 [ lookup-compression ] } { 262 [ lookup-photometric-interpretation ] } { 273 [ ] } + { 274 [ ] } { 277 [ ] } { 278 [ ] } { 279 [ ] } @@ -207,21 +318,32 @@ ERROR: bad-tiff-magic bytes ; { 284 [ ] } { 296 [ lookup-resolution-unit ] } { 317 [ lookup-predictor ] } + { 338 [ lookup-extra-samples ] } + { 339 [ lookup-sample-format ] } [ unhandled-ifd-entry swap 2array ] } case ; : process-ifd ( ifd -- ifd ) - dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; + dup ifd-entries>> + [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + +/* +: ifd-strips>buffer ( ifd -- ifd ) + [ + [ rows-per-strip find-tag n>> ] + [ image-length find-tag n>> ] bi + ] [ + strips>> [ length ] keep + ] bi assemble-image ; +*/ : (load-tiff) ( path -- tiff ) binary [ - read-header - read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + read-header [ + read-ifds + dup ifds>> [ process-ifd read-strips drop ] each + ] with-tiff-endianness ] with-file-reader ; -: load-tiff ( path -- tiff ) - (load-tiff) ; - -! TODO: duplicate ifds = error, seeking out of bounds = error +: load-tiff ( path -- tiff ) (load-tiff) ; From 41e0db098caff53221560f50bb46855123b2c43a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:43 -0600 Subject: [PATCH 118/170] make pack/unpack public --- basis/pack/pack.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 9078817206..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -87,12 +87,12 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input - : ch>packed-length ( ch -- n ) packed-length-table at ; inline @@ -113,14 +113,14 @@ PRIVATE> : start/end ( seq -- seq1 seq2 ) [ 0 [ + ] accumulate nip dup ] keep v+ ; inline +PRIVATE> + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map '[ [ _ cleave ] output>array ] ; -PRIVATE> - : unpack-native ( seq str -- seq ) '[ _ _ unpack ] with-native-endian ; inline From ebdd135d6281e0758d2641e005fbff4253de5749 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:36:46 -0600 Subject: [PATCH 119/170] gfortran returns float for REAL functions, not double like f2c --- basis/alien/fortran/fortran-tests.factor | 6 +++--- basis/alien/fortran/fortran.factor | 6 ++++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 9b618ef513..1b2ffda4a9 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -116,7 +116,7 @@ RECORD: FORTRAN_TEST_RECORD [ "int" { } ] [ "logical" fortran-ret-type>c-type ] unit-test -[ "double" { } ] +[ "float" { } ] [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] @@ -136,7 +136,7 @@ RECORD: FORTRAN_TEST_RECORD ! fortran-sig>c-sig -[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "float" { "int*" "char*" "float*" "double*" "long" } ] [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] unit-test @@ -213,7 +213,7 @@ unit-test [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] - [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ] 1 nkeep ! [fortran-results>] shuffle( reta aa -- reta aa ) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index c7688fbe3a..9327c7b02c 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -155,7 +155,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; -M: real-type (fortran-ret-type>c-type) drop "double" ; +! XXX F2C claims to return double for REAL typed functions +! XXX OSX Accelerate.framework uses float +! M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline @@ -374,7 +376,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic - return library function parameters return parse-arglist + return library function parameters return [ "void" ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: From 4623e9bd683df29dd7fc405e0679db4d8fd47967 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:01 -0600 Subject: [PATCH 120/170] another typo --- basis/math/blas/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 03043e54ed..7e0694ae4f 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -16,7 +16,7 @@ LIBRARY: blas FUNCTION: REAL SDSDOT ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DSDOT - ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: REAL SDOT ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DDOT From ddf8afbb7ee49c8b3b894928168ab6c113417190 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:12 -0600 Subject: [PATCH 121/170] more typos --- .../direct/complex-double/complex-double.factor | 2 +- .../direct/complex-float/complex-float.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor index 58af77b0c0..ae8d2b5fb3 100644 --- a/basis/specialized-arrays/direct/complex-double/complex-double.factor +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-double specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-double << "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor index d881c1e0d4..8971196297 100644 --- a/basis/specialized-arrays/direct/complex-float/complex-float.factor +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-float specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-float << "complex-float" define-direct-array >> From ad843a1bcf53f3a21f3ec13dbf24b5507dff0bc7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:45 -0600 Subject: [PATCH 122/170] iXamax returns a 1-based array index. decrement that shit --- basis/math/blas/vectors/vectors-docs.factor | 16 ++++++++-------- basis/math/blas/vectors/vectors.factor | 5 ++--- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index b37a4b966e..296437c32b 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -37,8 +37,8 @@ HELP: blas-vector-base { $list { { $link float-blas-vector } } { { $link double-blas-vector } } - { { $link float-complex-blas-vector } } - { { $link double-complex-blas-vector } } + { { $link complex-float-blas-vector } } + { { $link complex-double-blas-vector } } } "All of these subclasses share the same tuple layout:" { $list @@ -51,10 +51,10 @@ HELP: float-blas-vector { $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: double-blas-vector { $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: float-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: double-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-float-blas-vector +{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-double-blas-vector +{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: n*V+V! { $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } @@ -145,11 +145,11 @@ HELP: dvector{ HELP: cvector{ { $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ; HELP: zvector{ { $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ; { POSTPONE: svector{ POSTPONE: dvector{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 9a2f9a4350..a373ec7c5a 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,7 +1,6 @@ USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi -math.complex math.functions math.order sequences.complex -sequences.complex-components sequences sequences.private +math.complex math.functions math.order sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double @@ -165,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX ; + (prepare-nrm2) IXAMAX 1- ; M: VECTOR (blas-vector-like) drop ; From 5a90a0aae5aeb1646eebddb5d4231b534cd0b797 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:41:23 -0600 Subject: [PATCH 123/170] Fixing bug in render-hidden --- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 8003ab208b..562fe5a614 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -86,7 +86,7 @@ CHLOE: base hidden-form-field ; : render-hidden ( for -- xml ) - "," split [ hidden render>xml ] map ; + [ "," split [ hidden render>xml ] map ] [ f ] if* ; : compile-hidden-form-fields ( for -- ) '[ From 1279d6e8ea2fff622ca556c6f7fa4b266a923ca9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:46:02 -0600 Subject: [PATCH 124/170] Fixing furnace test/docs --- basis/furnace/furnace-tests.factor | 4 ++-- basis/furnace/utilities/utilities-docs.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f01260c68b..c591b848ec 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel -namespaces accessors io.streams.string urls ; +namespaces accessors io.streams.string urls xml.writer ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -31,7 +31,7 @@ M: base-path-check-responder call-responder* ] unit-test [ "" ] -[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +[ "&&&" "foo" hidden-form-field xml>string ] unit-test [ f ] [ request [ referrer ] with-variable ] unit-test diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index db44963f6e..e7fdaf64d6 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -25,8 +25,8 @@ HELP: hidden-form-field { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example - "USING: furnace.utilities io ;" - "\"bar\" \"foo\" hidden-form-field nl" + "USING: furnace.utilities io xml.writer ;" + "\"bar\" \"foo\" hidden-form-field write-xml nl" "" } } ; From 35c54a91ac5d937795b2ff9912f8d0aa719fb6bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:00 -0600 Subject: [PATCH 125/170] oops, leftover ORDER arguments from converting from CBLAS --- basis/math/blas/ffi/ffi.factor | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7e0694ae4f..77cee1aa82 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -122,13 +122,11 @@ SUBROUTINE: DROTM ! LEVEL 2 BLAS (MATRIX-VECTOR) -SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; -SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; @@ -155,13 +153,11 @@ SUBROUTINE: STPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; -SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; -SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; @@ -188,13 +184,11 @@ SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; -SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; @@ -221,13 +215,11 @@ SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; -SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; From d160b80dacbcf7e598613930fb83781df8804e7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:26 -0600 Subject: [PATCH 126/170] convert math.blas.matrices to use fortran calls --- basis/math/blas/matrices/matrices-docs.factor | 40 +++++------ basis/math/blas/matrices/matrices.factor | 72 +++++++++---------- 2 files changed, 54 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index f20a565e1f..b6e118836e 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -14,34 +14,34 @@ ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" { $subsection float-blas-vector } { $subsection double-blas-vector } -{ $subsection float-complex-blas-vector } -{ $subsection double-complex-blas-vector } +{ $subsection complex-float-blas-vector } +{ $subsection complex-double-blas-vector } "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:" { $subsection float-blas-matrix } { $subsection double-blas-matrix } -{ $subsection float-complex-blas-matrix } -{ $subsection double-complex-blas-matrix } +{ $subsection complex-float-blas-matrix } +{ $subsection complex-double-blas-matrix } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" { $subsection } { $subsection } "BLAS vectors and matrices can also be constructed from other Factor sequences:" { $subsection >float-blas-vector } { $subsection >double-blas-vector } -{ $subsection >float-complex-blas-vector } -{ $subsection >double-complex-blas-vector } +{ $subsection >complex-float-blas-vector } +{ $subsection >complex-double-blas-vector } { $subsection >float-blas-matrix } { $subsection >double-blas-matrix } -{ $subsection >float-complex-blas-matrix } -{ $subsection >double-complex-blas-matrix } ; +{ $subsection >complex-float-blas-matrix } +{ $subsection >complex-double-blas-matrix } ; ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" "Transposing and slicing matrices:" @@ -87,8 +87,8 @@ HELP: blas-matrix-base { $list { { $link float-blas-matrix } } { { $link double-blas-matrix } } - { { $link float-complex-blas-matrix } } - { { $link double-complex-blas-matrix } } + { { $link complex-float-blas-matrix } } + { { $link complex-double-blas-matrix } } } "All of these subclasses share the same tuple layout:" { $list @@ -104,14 +104,14 @@ HELP: float-blas-matrix { $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; HELP: double-blas-matrix { $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: float-complex-blas-matrix +HELP: complex-float-blas-matrix { $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: double-complex-blas-matrix +HELP: complex-double-blas-matrix { $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; { - float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix - float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector + float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix + float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector } related-words HELP: Mwidth @@ -272,7 +272,7 @@ HELP: cmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ { $syntax <" zmatrix{ @@ -281,7 +281,7 @@ HELP: zmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { POSTPONE: smatrix{ POSTPONE: dmatrix{ diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index d9653fca6f..6a948b6fe1 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,11 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel locals macros -math math.blas.cblas math.blas.vectors math.blas.vectors.private +math math.blas.ffi math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double specialized-arrays.float specialized-arrays.double -parser prettyprint.backend prettyprint.custom ; +specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double +specialized-arrays.complex-float specialized-arrays.complex-double +parser prettyprint.backend prettyprint.custom ascii ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) > [ CblasTrans ] [ CblasNoTrans ] if ; + transpose>> [ "T" ] [ "N" ] if ; GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) @@ -38,19 +40,18 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemv) - ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc - y ) + ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc + y ) A x y (validate-gemv) - CblasColMajor A (blas-transpose) A rows>> A cols>> - alpha >c-arg call + alpha A underlying>> A ld>> x underlying>> x inc>> - beta >c-arg call + beta y underlying>> y inc>> y ; inline @@ -64,13 +65,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-ger) - ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld - A ) + ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld + A ) x y A (validate-ger) - CblasColMajor A rows>> A cols>> - alpha >c-arg call + alpha x underlying>> x inc>> y underlying>> @@ -89,21 +89,20 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemm) - ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld - C ) + ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld + C ) A B C (validate-gemm) - CblasColMajor A (blas-transpose) B (blas-transpose) C rows>> C cols>> A Mwidth - alpha >c-arg call + alpha A underlying>> A ld>> B underlying>> B ld>> - beta >c-arg call + beta C underlying>> C ld>> C f >>transpose ; inline @@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) VECTOR IS ${TYPE}-blas-vector IS <${TYPE}-blas-vector> >ARRAY IS >${TYPE}-array -TYPE>ARG IS ${TYPE}>arg -XGEMV IS cblas_${T}gemv -XGEMM IS cblas_${T}gemm -XGERU IS cblas_${T}ger${U} -XGERC IS cblas_${T}ger${C} +XGEMV IS ${T}GEMV +XGEMM IS ${T}GEMM +XGERU IS ${T}GER${U} +XGERC IS ${T}GER${C} MATRIX DEFINES-CLASS ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix -XMATRIX{ DEFINES ${T}matrix{ + +t [ T >lower ] + +XMATRIX{ DEFINES ${t}matrix{ WHERE @@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like) drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY underlying>> ] (>matrix) - ; + [ >ARRAY underlying>> ] (>matrix) ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG ] (prepare-gemv) - [ XGEMV ] dip ; + (prepare-gemv) [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG ] (prepare-gemm) - [ XGEMM ] dip ; + (prepare-gemm) [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERU ] dip ; + (prepare-ger) [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERC ] dip ; + (prepare-ger) [ XGERC ] dip ; : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing @@ -304,12 +300,12 @@ M: MATRIX pprint-delims : define-real-blas-matrix ( TYPE T -- ) "" "" (define-blas-matrix) ; : define-complex-blas-matrix ( TYPE T -- ) - "u" "c" (define-blas-matrix) ; + "U" "C" (define-blas-matrix) ; -"float" "s" define-real-blas-matrix -"double" "d" define-real-blas-matrix -"float-complex" "c" define-complex-blas-matrix -"double-complex" "z" define-complex-blas-matrix +"float" "S" define-real-blas-matrix +"double" "D" define-real-blas-matrix +"complex-float" "C" define-complex-blas-matrix +"complex-double" "Z" define-complex-blas-matrix >> From 4325f5a7a9a08c6c9b67eccd2141acf6b353138f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:04:37 -0600 Subject: [PATCH 127/170] kill math.blas.cblas --- basis/math/blas/cblas/authors.txt | 1 - basis/math/blas/cblas/cblas.factor | 574 ------------------ basis/math/blas/cblas/summary.txt | 1 - basis/math/blas/cblas/tags.txt | 2 - basis/math/blas/matrices/matrices-docs.factor | 2 +- 5 files changed, 1 insertion(+), 579 deletions(-) delete mode 100644 basis/math/blas/cblas/authors.txt delete mode 100644 basis/math/blas/cblas/cblas.factor delete mode 100644 basis/math/blas/cblas/summary.txt delete mode 100644 basis/math/blas/cblas/tags.txt diff --git a/basis/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt deleted file mode 100644 index f13c9c1e77..0000000000 --- a/basis/math/blas/cblas/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor deleted file mode 100644 index 2a2e9e3a72..0000000000 --- a/basis/math/blas/cblas/cblas.factor +++ /dev/null @@ -1,574 +0,0 @@ -USING: alien alien.c-types alien.syntax kernel system -combinators ; -IN: math.blas.cblas - -<< -: load-atlas ( -- ) - "atlas" "libatlas.so" "cdecl" add-library ; -: load-fortran ( -- ) - "I77" "libI77.so" "cdecl" add-library - "F77" "libF77.so" "cdecl" add-library ; -: load-blas ( -- ) - "blas" "libblas.so" "cdecl" add-library ; - -"cblas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } - { [ os netbsd? ] [ - load-fortran load-blas - "/usr/local/lib/libcblas.so" "cdecl" add-library - ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } - [ "libblas.so" "cdecl" add-library ] -} cond ->> - -LIBRARY: cblas - -TYPEDEF: int CBLAS_ORDER -CONSTANT: CblasRowMajor 101 -CONSTANT: CblasColMajor 102 - -TYPEDEF: int CBLAS_TRANSPOSE -CONSTANT: CblasNoTrans 111 -CONSTANT: CblasTrans 112 -CONSTANT: CblasConjTrans 113 - -TYPEDEF: int CBLAS_UPLO -CONSTANT: CblasUpper 121 -CONSTANT: CblasLower 122 - -TYPEDEF: int CBLAS_DIAG -CONSTANT: CblasNonUnit 131 -CONSTANT: CblasUnit 132 - -TYPEDEF: int CBLAS_SIDE -CONSTANT: CblasLeft 141 -CONSTANT: CblasRight 142 - -TYPEDEF: int CBLAS_INDEX - -C-STRUCT: float-complex - { "float" "real" } - { "float" "imag" } ; -C-STRUCT: double-complex - { "double" "real" } - { "double" "imag" } ; - -! Level 1 BLAS (scalar-vector and vector-vector) - -FUNCTION: float cblas_sdsdot - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_dsdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: float cblas_sdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_ddot - ( int N, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_cdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: void cblas_zdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_zdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: float cblas_snrm2 - ( int N, float* X, int incX ) ; -FUNCTION: float cblas_sasum - ( int N, float* X, int incX ) ; - -FUNCTION: double cblas_dnrm2 - ( int N, double* X, int incX ) ; -FUNCTION: double cblas_dasum - ( int N, double* X, int incX ) ; - -FUNCTION: float cblas_scnrm2 - ( int N, void* X, int incX ) ; -FUNCTION: float cblas_scasum - ( int N, void* X, int incX ) ; - -FUNCTION: double cblas_dznrm2 - ( int N, void* X, int incX ) ; -FUNCTION: double cblas_dzasum - ( int N, void* X, int incX ) ; - -FUNCTION: CBLAS_INDEX cblas_isamax - ( int N, float* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_idamax - ( int N, double* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_icamax - ( int N, void* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_izamax - ( int N, void* X, int incX ) ; - -FUNCTION: void cblas_sswap - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_scopy - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_saxpy - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; - -FUNCTION: void cblas_dswap - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_dcopy - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_daxpy - ( int N, double alpha, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_ccopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_caxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_zswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zcopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zaxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_sscal - ( int N, float alpha, float* X, int incX ) ; -FUNCTION: void cblas_dscal - ( int N, double alpha, double* X, int incX ) ; -FUNCTION: void cblas_cscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_zscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_csscal - ( int N, float alpha, void* X, int incX ) ; -FUNCTION: void cblas_zdscal - ( int N, double alpha, void* X, int incX ) ; - -FUNCTION: void cblas_srotg - ( float* a, float* b, float* c, float* s ) ; -FUNCTION: void cblas_srotmg - ( float* d1, float* d2, float* b1, float b2, float* P ) ; -FUNCTION: void cblas_srot - ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ; -FUNCTION: void cblas_srotm - ( int N, float* X, int incX, float* Y, int incY, float* P ) ; - -FUNCTION: void cblas_drotg - ( double* a, double* b, double* c, double* s ) ; -FUNCTION: void cblas_drotmg - ( double* d1, double* d2, double* b1, double b2, double* P ) ; -FUNCTION: void cblas_drot - ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ; -FUNCTION: void cblas_drotm - ( int N, double* X, int incX, double* Y, int incY, double* P ) ; - -! Level 2 BLAS (matrix-vector) - -FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - float alpha, float* A, int lda, - float* X, int incX, float beta, - float* Y, int incY ) ; -FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, float alpha, - float* A, int lda, float* X, - int incX, float beta, float* Y, int incY ) ; -FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; -FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, float* X, - int incX ) ; -FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; - -FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - double alpha, double* A, int lda, - double* X, int incX, double beta, - double* Y, int incY ) ; -FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, double alpha, - double* A, int lda, double* X, - int incX, double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; -FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, double* X, - int incX ) ; -FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; - -FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - -FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - - -FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* Ap, - float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N, - float alpha, float* X, int incX, - float* Y, int incY, float* A, int lda ) ; -FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* A, int lda ) ; -FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Ap ) ; -FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A, - int lda ) ; -FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A ) ; - -FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* Ap, - double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N, - double alpha, double* X, int incX, - double* Y, int incY, double* A, int lda ) ; -FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* A, int lda ) ; -FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Ap ) ; -FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A, - int lda ) ; -FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A ) ; - - -FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -! Level 3 BLAS (matrix-matrix) - -FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, float alpha, float* A, - int lda, float* B, int ldb, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; -FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; - -FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, double alpha, double* A, - int lda, double* B, int ldb, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; -FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; - -FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, void* A, int lda, - float beta, void* C, int ldc ) ; -FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, float beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, void* A, int lda, - double beta, void* C, int ldc ) ; -FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, double beta, - void* C, int ldc ) ; - diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt deleted file mode 100644 index c72e78eb0d..0000000000 --- a/basis/math/blas/cblas/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt deleted file mode 100644 index 241ec1ecda..0000000000 --- a/basis/math/blas/cblas/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -math -bindings diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index b6e118836e..17d2f9ccd1 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" { $subsection "math.blas.vectors" } "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" { $subsection "math.blas.matrices" } -"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; +"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" From bfc2af7ea13679158f5a88df190f4730b5dde946 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:22:43 -0600 Subject: [PATCH 128/170] remove unnecessary calls to underlying>> from math.blas --- basis/math/blas/vectors/vectors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index a373ec7c5a..84b5fd9e6f 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -33,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) : shorter-length ( v1 v2 -- length ) [ length>> ] bi@ min ; inline : data-and-inc ( v -- data inc ) - [ underlying>> ] [ inc>> ] bi ; inline + [ ] [ inc>> ] bi ; inline : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc ) [ data-and-inc ] bi@ ; inline From fecc9890985d2d75f04de117356e4f85f616ebfd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:23:56 -0600 Subject: [PATCH 129/170] get rid of underlying>>s, again --- basis/math/blas/matrices/matrices.factor | 28 ++++++++++++------------ 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 6a948b6fe1..6fad545501 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -47,19 +47,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - A underlying>> + A A ld>> - x underlying>> + x x inc>> beta - y underlying>> + y y inc>> y ; inline : (validate-ger) ( x y A -- ) { - [ nip [ length>> ] [ Mheight ] bi* = ] - [ nipd [ length>> ] [ Mwidth ] bi* = ] + [ [ length>> ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ length>> ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched vertices and matrix in vector outer product" throw ] unless ; @@ -71,19 +71,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - x underlying>> + x x inc>> - y underlying>> + y y inc>> - A underlying>> + A A ld>> A f >>transpose ; inline : (validate-gemm) ( A B C -- ) { - [ drop [ Mwidth ] [ Mheight ] bi* = ] - [ nip [ Mheight ] bi@ = ] - [ nipd [ Mwidth ] bi@ = ] + [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ] + [ [ Mheight ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ; @@ -98,12 +98,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) C cols>> A Mwidth alpha - A underlying>> + A A ld>> - B underlying>> + B B ld>> beta - C underlying>> + C C ld>> C f >>transpose ; inline From 296a1ce0a93e9c66dd0220e436df76c7b31c9ddc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:26:12 -0600 Subject: [PATCH 130/170] unit tests for complex specialized-arrays --- .../complex-double/complex-double-tests.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double-tests.factor diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor new file mode 100644 index 0000000000..9f2bcc99b7 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor @@ -0,0 +1,13 @@ +USING: kernel sequences specialized-arrays.complex-double tools.test ; +IN: specialized-arrays.complex-double.tests + +[ C{ 3.0 2.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test + +[ C{ 1.0 0.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test + +[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [ + complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } + dup [ C{ 6.0 -7.0 } 1 ] dip set-nth +] unit-test From 4ee82b19f66a4b6ac27a946466cc3d68442c2bbf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:47:55 -0600 Subject: [PATCH 131/170] rewrite shuffle( -- ) to avoid locals primitives --- basis/shuffle/shuffle.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 632c09e338..d375ec9c20 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,23 +1,22 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs effects.parser generalizations +USING: accessors assocs combinators effects.parser generalizations hashtables kernel locals locals.backend macros make math parser sequences ; IN: shuffle locals-assoc ( sequence -- assoc ) - dup length dup 1- [ - ] curry map zip >hashtable ; +: >index-assoc ( sequence -- assoc ) + dup length zip >hashtable ; PRIVATE> MACRO: shuffle-effect ( effect -- ) - [ out>> ] [ in>> >locals-assoc ] bi + [ out>> ] [ in>> >index-assoc ] bi [ - [ nip assoc-size , \ load-locals , ] - [ [ at , \ get-local , ] curry each ] - [ nip assoc-size , \ drop-locals , ] 2tri + [ nip assoc-size , \ narray , ] + [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi ] [ ] make ; : shuffle( From efc88c5b696f070916cbdd835f01a175f08b3c01 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 9 Feb 2009 18:11:42 -0600 Subject: [PATCH 132/170] Remove nipd, 3nip, 4nip and tuckd from basis/shuffle --- basis/csv/csv-tests.factor | 4 ++-- basis/db/postgresql/lib/lib.factor | 6 +++--- basis/math/polynomials/polynomials.factor | 4 ++-- basis/regexp/traversal/traversal.factor | 5 ++--- basis/shuffle/shuffle-tests.factor | 2 -- basis/shuffle/shuffle.factor | 8 -------- extra/project-euler/002/002.factor | 4 ++-- extra/reports/noise/noise.factor | 3 --- 8 files changed, 11 insertions(+), 25 deletions(-) diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 4d78c2af86..50bc3836f5 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,11 +1,11 @@ -USING: io.streams.string csv tools.test shuffle kernel strings +USING: io.streams.string csv tools.test kernel strings io.pathnames io.files.unique io.encodings.utf8 io.files io.directories ; IN: csv.tests ! I like to name my unit tests : named-unit-test ( name output input -- ) - nipd unit-test ; inline + unit-test drop ; inline ! tests nicked from the wikipedia csv article ! http://en.wikipedia.org/wiki/Comma-separated_values diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 05114a4deb..0d50d1ab2c 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -3,7 +3,7 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators -libc shuffle calendar.format byte-arrays destructors prettyprint +libc calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 alien.strings io.streams.byte-array summary present urls specialized-arrays.uint specialized-arrays.alien db.private ; @@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue utf8 alien>string - dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ; + dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; @@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength dup 0 > [ - 3nip + [ 3drop ] dip [ memory>byte-array >string 0 diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 1ece3d915e..749bde3a10 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel make math math.order math.vectors sequences shuffle +USING: arrays kernel make math math.order math.vectors sequences splitting vectors ; IN: math.polynomials @@ -75,7 +75,7 @@ PRIVATE> PRIVATE> : pgcd ( p q -- a d ) - swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ; + [ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ; : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index d8c25eda18..104a6c2ce1 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators kernel math quotations sequences regexp.parser regexp.classes fry arrays -combinators.short-circuit regexp.utils prettyprint regexp.nfa -shuffle ; +combinators.short-circuit regexp.utils prettyprint regexp.nfa ; IN: regexp.traversal TUPLE: dfa-traverser @@ -170,7 +169,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) ] [ drop ] if ; : match-default ( transition from-state table -- to-state/f ) - nipd transitions>> at t swap at ; + [ drop ] 2dip transitions>> at t swap at ; : match-transition ( obj from-state dfa -- to-state/f ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..f8f83a9c08 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -1,5 +1,3 @@ USING: shuffle tools.test ; -[ 8 ] [ 5 6 7 8 3nip ] unit-test -[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..10fb8b01dd 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -6,14 +6,6 @@ IN: shuffle : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline -: nipd ( a b c -- b c ) rot drop ; inline - -: 3nip ( a b c d -- d ) 3 nnip ; inline - -: 4nip ( a b c d e -- e ) 4 nnip ; inline - : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4drop ( a b c d -- ) 3drop drop ; inline - -: tuckd ( x y z -- z x y z ) 2 ntuck ; inline diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index da20c874b5..9c462b6b2e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences shuffle ; +USING: kernel math sequences ; IN: project-euler.002 ! http://projecteuler.net/index.php?section=problems&id=2 @@ -41,7 +41,7 @@ PRIVATE> ! ------------------- : fib-upto* ( n -- seq ) - 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip + 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip but-last-slice { 0 1 } prepend ; : euler002a ( -- answer ) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 3e47adac0b..89e00f88c5 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -25,7 +25,6 @@ IN: reports.noise { 3drop 1 } { 3dup 2 } { 3keep 3 } - { 3nip 4 } { 3slip 3 } { 4drop 2 } { 4dup 3 } @@ -50,7 +49,6 @@ IN: reports.noise { ndrop 2 } { ndup 3 } { nip 2 } - { nipd 3 } { nkeep 5 } { npick 6 } { nrot 5 } @@ -66,7 +64,6 @@ IN: reports.noise { swap 1 } { swapd 3 } { tuck 2 } - { tuckd 4 } { with 1/2 } { bi 1/2 } From b5a96dccdf7f44ce9f3df5eac2d2f5767dc3c6ef Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 18:36:36 -0600 Subject: [PATCH 133/170] Slight cleanup in xml-rpc --- basis/xml-rpc/xml-rpc.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 9632cbb1ac..690ebe94f8 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -126,11 +126,11 @@ TAG: int xml>item children>number ; TAG: double xml>item children>number ; TAG: boolean xml>item - dup children>string { - { [ dup "1" = ] [ 2drop t ] } - { [ "0" = ] [ drop f ] } + children>string { + { "1" [ t ] } + { "0" [ f ] } [ "Bad boolean" server-error ] - } cond ; + } case ; : unstruct-member ( tag -- ) children-tags first2 From 3672bcb08f12e4d4059d988152c9fc3956adab08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 18:39:46 -0600 Subject: [PATCH 134/170] loading some tiff files works! --- extra/graphics/tiff/tiff.factor | 6 ++++-- extra/graphics/viewer/viewer.factor | 30 ++++++++++++++++++++++------- 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 9461403805..b4e57d4ed6 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -14,6 +14,7 @@ the-answer ifd-offset ifds ; + CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; @@ -327,8 +328,9 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; /* -: ifd-strips>buffer ( ifd -- ifd ) [ [ rows-per-strip find-tag n>> ] [ image-length find-tag n>> ] bi @@ -342,7 +344,7 @@ ERROR: bad-small-ifd-type n ; read-header [ read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-tiff-endianness ] with-file-reader ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 8e0b1ec43c..90425722da 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators graphics.bitmap kernel math math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render graphics.tiff sequences ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -21,6 +21,14 @@ M: graphics-gadget draw-gadget* ( gadget -- ) \ graphics-gadget new-gadget swap >>image ; +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + M: bitmap draw-image ( bitmap -- ) dup height>> 0 < [ 0 0 glRasterPos2i @@ -32,12 +40,7 @@ M: bitmap draw-image ( bitmap -- ) [ width>> ] keep [ [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case + bit-count>> bits>gl-params ] keep array>> glDrawPixels ; M: bitmap width ( bitmap -- ) width>> ; @@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; + +M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; + +M: tiff draw-image ( tiff -- ) + [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip + ifds>> first + { + [ image-width find-tag n>> ] + [ image-length find-tag n>> ] + [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; From 03f7a72d41fb448943f771b3a5f535f6560bbfb8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 18:44:36 -0600 Subject: [PATCH 135/170] alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 56 +++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 basis/alien/fortran/fortran-docs.factor diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor new file mode 100644 index 0000000000..1b942d30c5 --- /dev/null +++ b/basis/alien/fortran/fortran-docs.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2009 Joe Groff +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences strings ; +QUALIFIED-WITH: alien.syntax c +IN: alien.fortran + +ARTICLE: "alien.fortran-types" "Fortran types" +"The Fortran FFI recognizes the following Fortran types:" +{ $list + { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." } + { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." } + { { $snippet "REAL" } " specifies a single-precision floating-point real value." } + { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." } + { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." } + { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } + { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } + { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." } +} +"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; + +HELP: FUNCTION: +{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: SUBROUTINE: +{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: LIBRARY: +{ $syntax "LIBRARY: name" } +{ $values { "name" "a logical library name" } } +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ; + +HELP: RECORD: +{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } +{ $description "Defines a Fortran record type with the given slots." } ; + +HELP: fortran-invoke +{ $values + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } +} +{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } +; + +ARTICLE: "alien.fortran" "Fortran FFI" +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +{ $subsection "alien.fortran-types" } +{ $subsection POSTPONE: LIBRARY: } +{ $subsection POSTPONE: FUNCTION: } +{ $subsection POSTPONE: SUBROUTINE: } +{ $subsection POSTPONE: RECORD: } +{ $subsection fortran-invoke } +; + +ABOUT: "alien.fortran" From f7d9f2ab2e5ea2a4bf519733cf0f79d04fa1f944 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:02:20 -0600 Subject: [PATCH 136/170] typo in alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 1b942d30c5..4accbf5965 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -44,7 +44,7 @@ HELP: fortran-invoke ; ARTICLE: "alien.fortran" "Fortran FFI" -"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." { $subsection "alien.fortran-types" } { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } From fbba25e968c0513605092fa1500fbcb8761a8540 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:16:46 -0600 Subject: [PATCH 137/170] clean up tiff --- extra/graphics/tiff/tiff.factor | 262 ++++++++++------------------ extra/graphics/viewer/viewer.factor | 10 +- 2 files changed, 96 insertions(+), 176 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index b4e57d4ed6..0481af8747 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -4,183 +4,121 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping ; -USE: multiline - IN: graphics.tiff -TUPLE: tiff -endianness -the-answer -ifd-offset -ifds ; - +TUPLE: tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips buffer ; - CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; - CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -TUPLE: photometric-interpretation color ; - -CONSTRUCTOR: photometric-interpretation ( color -- object ) ; - -SINGLETONS: white-is-zero black-is-zero rgb palette-color ; - +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; ERROR: bad-photometric-interpretation n ; - : lookup-photometric-interpretation ( n -- singleton ) { - { 0 [ white-is-zero ] } - { 1 [ black-is-zero ] } - { 2 [ rgb ] } - { 3 [ palette-color ] } + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } [ bad-photometric-interpretation ] - } case ; - - -TUPLE: compression method ; - -CONSTRUCTOR: compression ( method -- object ) ; - -SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + } case ; +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; ERROR: bad-compression n ; - : lookup-compression ( n -- compression ) { - { 1 [ no-compression ] } - { 2 [ CCITT-2 ] } - { 5 [ lzw ] } - { 32773 [ pack-bits ] } + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } [ bad-compression ] - } case ; - -TUPLE: image-length n ; -CONSTRUCTOR: image-length ( n -- object ) ; - -TUPLE: image-width n ; -CONSTRUCTOR: image-width ( n -- object ) ; - -TUPLE: x-resolution n ; -CONSTRUCTOR: x-resolution ( n -- object ) ; - -TUPLE: y-resolution n ; -CONSTRUCTOR: y-resolution ( n -- object ) ; - -TUPLE: rows-per-strip n ; -CONSTRUCTOR: rows-per-strip ( n -- object ) ; - -TUPLE: strip-offsets n ; -CONSTRUCTOR: strip-offsets ( n -- object ) ; - -TUPLE: strip-byte-counts n ; -CONSTRUCTOR: strip-byte-counts ( n -- object ) ; - -TUPLE: bits-per-sample n ; -CONSTRUCTOR: bits-per-sample ( n -- object ) ; - -TUPLE: samples-per-pixel n ; -CONSTRUCTOR: samples-per-pixel ( n -- object ) ; - -SINGLETONS: no-resolution-unit -inch-resolution-unit -centimeter-resolution-unit ; - -TUPLE: resolution-unit type ; -CONSTRUCTOR: resolution-unit ( type -- object ) ; + } case ; +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; ERROR: bad-resolution-unit n ; - : lookup-resolution-unit ( n -- object ) { - { 1 [ no-resolution-unit ] } - { 2 [ inch-resolution-unit ] } - { 3 [ centimeter-resolution-unit ] } + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } [ bad-resolution-unit ] - } case ; - - -TUPLE: predictor type ; -CONSTRUCTOR: predictor ( type -- object ) ; - -SINGLETONS: no-predictor horizontal-differencing-predictor ; + } case ; +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; ERROR: bad-predictor n ; - : lookup-predictor ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } [ bad-predictor ] - } case ; - - -TUPLE: planar-configuration type ; -CONSTRUCTOR: planar-configuration ( type -- object ) ; - -SINGLETONS: chunky planar ; + } case ; +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; ERROR: bad-planar-configuration n ; - : lookup-planar-configuration ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; -TUPLE: sample-format n ; -CONSTRUCTOR: sample-format ( n -- object ) ; ERROR: bad-sample-format n ; - -SINGLETONS: sample-unsigned-integer sample-signed-integer -sample-ieee-float sample-undefined-data ; - +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; : lookup-sample-format ( seq -- object ) [ { - { 1 [ sample-unsigned-integer ] } - { 2 [ sample-signed-integer ] } - { 3 [ sample-ieee-float ] } - { 4 [ sample-undefined-data ] } + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } [ bad-sample-format ] } case - ] map ; + ] map ; - -TUPLE: extra-samples n ; -CONSTRUCTOR: extra-samples ( n -- object ) ; ERROR: bad-extra-samples n ; - -SINGLETONS: unspecified-alpha-data associated-alpha-data -unassociated-alpha-data ; - +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; : lookup-extra-samples ( seq -- object ) { - { 0 [ unspecified-alpha-data ] } - { 1 [ associated-alpha-data ] } - { 2 [ unassociated-alpha-data ] } + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } [ bad-extra-samples ] - } case ; + } case ; - -TUPLE: orientation n ; -CONSTRUCTOR: orientation ( n -- object ) ; - - -TUPLE: new-subfile-type n ; -CONSTRUCTOR: new-subfile-type ( n -- object ) ; +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; - : tiff-endianness ( byte-array -- ? ) { { B{ CHAR: M CHAR: M } [ big-endian ] } @@ -188,9 +126,6 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; -: with-tiff-endianness ( tiff quot -- tiff ) - [ dup endianness>> ] dip with-endianness ; inline - : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -198,9 +133,7 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; -: push-ifd ( tiff ifd -- tiff ) - over ifds>> push ; - ! over [ dup class ] [ ifds>> ] bi* set-at ; +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; : read-ifd ( -- ifd ) 2 read endian> @@ -221,23 +154,18 @@ ERROR: no-tag class ; dupd at* [ nip t ] [ drop f ] if ; inline : find-tag ( idf class -- tag ) - swap processed-tags>> - ?at [ no-tag ] unless ; + swap processed-tags>> ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) dup - [ strip-byte-counts find-tag n>> ] - [ strip-offsets find-tag n>> ] bi + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi 2dup [ integer? ] both? [ seek-absolute seek-input read 1array ] [ [ seek-absolute seek-input read ] { } 2map-as ] if >>strips ; -! ERROR: unhandled-ifd-entry data n ; - -: unhandled-ifd-entry ; - ERROR: unknown-ifd-type n ; : bytes>bits ( n/byte-array -- n ) @@ -301,51 +229,43 @@ ERROR: bad-small-ifd-type n ; [ type>> ] tri offset-bytes>obj ] if ; -: process-ifd-entry ( ifd-entry -- object ) +: process-ifd-entry ( ifd-entry -- value class ) [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ ] } - { 256 [ ] } - { 257 [ ] } - { 258 [ ] } - { 259 [ lookup-compression ] } - { 262 [ lookup-photometric-interpretation ] } - { 273 [ ] } - { 274 [ ] } - { 277 [ ] } - { 278 [ ] } - { 279 [ ] } - { 282 [ ] } - { 283 [ ] } - { 284 [ ] } - { 296 [ lookup-resolution-unit ] } - { 317 [ lookup-predictor ] } - { 338 [ lookup-extra-samples ] } - { 339 [ lookup-sample-format ] } - [ unhandled-ifd-entry swap 2array ] + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] } case ; : process-ifd ( ifd -- ifd ) dup ifd-entries>> - [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; -/* - [ - [ rows-per-strip find-tag n>> ] - [ image-length find-tag n>> ] bi - ] [ - strips>> [ length ] keep - ] bi assemble-image ; -*/ : (load-tiff) ( path -- tiff ) binary [ - read-header [ + read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-tiff-endianness + ] with-endianness ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 90425722da..517ab4e010 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -52,15 +52,15 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; -M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; +M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; M: tiff draw-image ( tiff -- ) [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip ifds>> first { - [ image-width find-tag n>> ] - [ image-length find-tag n>> ] - [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum bits>gl-params ] [ buffer>> ] } cleave glDrawPixels ; From 045cd614c669a892a5c45ec3526c95f1f96f7d5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:18:18 -0600 Subject: [PATCH 138/170] make more taxes vocabs load by default --- extra/taxes/usa/futa/futa.factor | 3 +-- extra/taxes/usa/usa.factor | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..efdb969c01 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals -namespaces sequences money math.order taxes.usa.w4 ; +namespaces sequences money math.order taxes.usa.w4 +taxes.usa.futa math.finance taxes.usa.fica +taxes.usa.federal ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) From 0d67f41ae6cc8551ea09e73bcdbf5a662e6f4d7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:28:21 -0600 Subject: [PATCH 139/170] update specialized-arrays docs --- basis/specialized-arrays/specialized-arrays-docs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 1c1b3dbc59..9015cccd8f 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -28,6 +28,8 @@ $nl { $snippet "ulonglong" } { $snippet "float" } { $snippet "double" } + { $snippet "complex-float" } + { $snippet "complex-double" } { $snippet "void*" } { $snippet "bool" } } From 992da4c9675a3d346b5a69dfdb659190434e744f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:19:18 -0600 Subject: [PATCH 140/170] Fix copy-vm word on Unix --- basis/tools/deploy/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 22d6eb2ffa..ff851edce6 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -12,7 +12,7 @@ destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) - [ prepend-path ] dip append vm over copy-file ; + prepend-path vm over copy-file ; : copy-fonts ( name dir -- ) deploy-ui? get [ From a1e45570f5e425dd62a72cfd41781ae391b8e85d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:26 -0600 Subject: [PATCH 141/170] rename graphics to images, add an word to load a path --- extra/images/authors.txt | 1 + extra/images/backend/authors.txt | 1 + extra/images/backend/backend.factor | 18 ++ extra/images/bitmap/authors.txt | 1 + extra/images/bitmap/bitmap-tests.factor | 30 +++ extra/images/bitmap/bitmap.factor | 146 ++++++++++++ extra/images/images.factor | 13 ++ extra/images/tags.txt | 1 + extra/images/test-images/1bit.bmp | Bin 0 -> 1662 bytes extra/images/test-images/octagon.tiff | Bin 0 -> 4334 bytes extra/images/test-images/rgb.tiff | Bin 0 -> 7916 bytes extra/images/test-images/rgb4bit.bmp | Bin 0 -> 5318 bytes extra/images/test-images/rgb8bit.bmp | Bin 0 -> 11078 bytes extra/images/test-images/thiswayup24.bmp | Bin 0 -> 60054 bytes extra/images/tiff/authors.txt | 1 + extra/images/tiff/tiff-tests.factor | 11 + extra/images/tiff/tiff.factor | 283 +++++++++++++++++++++++ extra/images/viewer/authors.txt | 1 + extra/images/viewer/viewer.factor | 69 ++++++ 19 files changed, 576 insertions(+) create mode 100644 extra/images/authors.txt create mode 100644 extra/images/backend/authors.txt create mode 100644 extra/images/backend/backend.factor create mode 100755 extra/images/bitmap/authors.txt create mode 100644 extra/images/bitmap/bitmap-tests.factor create mode 100755 extra/images/bitmap/bitmap.factor create mode 100644 extra/images/images.factor create mode 100644 extra/images/tags.txt create mode 100644 extra/images/test-images/1bit.bmp create mode 100644 extra/images/test-images/octagon.tiff create mode 100755 extra/images/test-images/rgb.tiff create mode 100644 extra/images/test-images/rgb4bit.bmp create mode 100644 extra/images/test-images/rgb8bit.bmp create mode 100644 extra/images/test-images/thiswayup24.bmp create mode 100755 extra/images/tiff/authors.txt create mode 100755 extra/images/tiff/tiff-tests.factor create mode 100755 extra/images/tiff/tiff.factor create mode 100755 extra/images/viewer/authors.txt create mode 100644 extra/images/viewer/viewer.factor diff --git a/extra/images/authors.txt b/extra/images/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/authors.txt b/extra/images/backend/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor new file mode 100644 index 0000000000..ef2a9a4248 --- /dev/null +++ b/extra/images/backend/backend.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel ; +IN: images.backend + +TUPLE: image width height depth pitch buffer ; + +GENERIC: load-image* ( path tuple -- image ) + +: load-image ( path class -- image ) + new load-image* ; + +: new-image ( width height depth buffer class -- image ) + new + swap >>buffer + swap >>depth + swap >>height + swap >>width ; inline diff --git a/extra/images/bitmap/authors.txt b/extra/images/bitmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/bitmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..6865bfee3c --- /dev/null +++ b/extra/images/bitmap/bitmap-tests.factor @@ -0,0 +1,30 @@ +USING: images.bitmap images.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; +IN: images.bitmap.tests + +: test-bitmap32-alpha ( -- path ) + "resource:extra/images/bitmap/test-images/32alpha.bmp" ; + +: test-bitmap24 ( -- path ) + "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + +: test-bitmap16 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + +: test-bitmap8 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + +: test-bitmap4 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + +: test-bitmap1 ( -- path ) + "resource:extra/images/bitmap/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor new file mode 100755 index 0000000000..220cdc153f --- /dev/null +++ b/extra/images/bitmap/bitmap.factor @@ -0,0 +1,146 @@ +! Copyright (C) 2007, 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types arrays byte-arrays columns +combinators fry grouping io io.binary io.encodings.binary +io.files kernel libc macros math math.bitwise math.functions +namespaces opengl opengl.gl prettyprint sequences strings +summary ui ui.gadgets.panes images.backend ; +IN: images.bitmap + +TUPLE: bitmap-image < image ; + +! Currently can only handle 24/32bit bitmaps. +! Handles row-reversed bitmaps (their height is negative) + +TUPLE: bitmap magic size reserved offset header-length width +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +alpha-channel-zero? +buffer ; + +: array-copy ( bitmap array -- bitmap array' ) + over size-image>> abs memory>byte-array ; + +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + +: 8bit>buffer ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +ERROR: bmp-not-supported n ; + +: raw-bitmap>buffer ( bitmap -- array ) + dup bit-count>> + { + { 32 [ color-index>> ] } + { 24 [ color-index>> ] } + { 16 [ bmp-not-supported ] } + { 8 [ 8bit>buffer ] } + { 4 [ bmp-not-supported ] } + { 2 [ bmp-not-supported ] } + { 1 [ bmp-not-supported ] } + } case >byte-array ; + +ERROR: bitmap-magic ; + +M: bitmap-magic summary + drop "First two bytes of bitmap stream must be 'BM'" ; + +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; + +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; + +: rgb-quads-length ( bitmap -- n ) + [ offset>> 14 - ] [ header-length>> ] bi - ; + +: color-index-length ( bitmap -- n ) + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; + +: parse-bitmap ( bitmap -- bitmap ) + dup rgb-quads-length read >>rgb-quads + dup color-index-length read >>color-index ; + +: load-bitmap ( path -- bitmap ) + binary [ + bitmap new + parse-file-header parse-bitmap-header parse-bitmap + ] with-file-reader ; + +: alpha-channel-zero? ( bitmap -- ? ) + buffer>> 4 3 [ 0 = ] all? ; + +: bitmap>image ( bitmap -- bitmap-image ) + { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + bitmap-image new-image ; + +M: bitmap-image load-image* ( path bitmap -- bitmap-image ) + drop load-bitmap + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? + bitmap>image ; + +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + +: save-bitmap ( bitmap path -- ) + binary [ + B{ CHAR: B CHAR: M } write + [ + buffer>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi + ] with-file-writer ; diff --git a/extra/images/images.factor b/extra/images/images.factor new file mode 100644 index 0000000000..eb4fc63fee --- /dev/null +++ b/extra/images/images.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: constructors kernel splitting unicode.case combinators +accessors images.bitmap images.tiff images.backend io.backend +io.pathnames ; +IN: images + +: ( path -- image ) + normalize-path dup "." split1-last nip >lower + { + { "bmp" [ bitmap-image load-image ] } + { "tiff" [ tiff-image load-image ] } + } case ; diff --git a/extra/images/tags.txt b/extra/images/tags.txt new file mode 100644 index 0000000000..04b54a06f4 --- /dev/null +++ b/extra/images/tags.txt @@ -0,0 +1 @@ +bitmap graphics diff --git a/extra/images/test-images/1bit.bmp b/extra/images/test-images/1bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2f244c1d058bfd63c99009e24e43db3d2af59902 GIT binary patch literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| literal 0 HcmV?d00001 diff --git a/extra/images/test-images/octagon.tiff b/extra/images/test-images/octagon.tiff new file mode 100644 index 0000000000000000000000000000000000000000..2b4ba3950db91cabdca87201b034b9d5bb97bdb3 GIT binary patch literal 4334 zcmebEWzb?^5a9U#|33ph%)r3Fk)M>iq_wp1aC33PQDSjsblTPcPoE|G*KPfGV*9@T zxG*8RtFp_tf4uVg|Cj6UNWvgJmDy$6gS`C~;Bx~m`$7ID*KU|wL2dw<5$x?Z50@LT z*-s6-G2GzeKNp)D(Cw$D-B{c(2i*{EN+;M>;{vx~ f5E45W%m%sb8PE)%?GWg(_8bGqA21r|GB5-H7Z-?3 literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb.tiff b/extra/images/test-images/rgb.tiff new file mode 100755 index 0000000000000000000000000000000000000000..71cbaa9d6e807156f7da39a5b116c9edb3b0c9e1 GIT binary patch literal 7916 zcmeHMcT^MWw+#r=t3X6RRC<#hYUoXR4bnxLK!S7xL9Q1Cgh&@qz)BGldhfkA=^#Z! zK)@iqNqZASuUB2~z4iWmzr{LhhA%Uj$#>4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb4bit.bmp b/extra/images/test-images/rgb4bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0c6f00d06c025f6947899450afd91ace50e5b57a GIT binary patch literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b>ifds ; + +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; + +TUPLE: ifd-entry tag type count offset/value ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; + +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; +ERROR: bad-photometric-interpretation n ; +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } + [ bad-photometric-interpretation ] + } case ; + +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; +ERROR: bad-compression n ; +: lookup-compression ( n -- compression ) + { + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } + [ bad-compression ] + } case ; + +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; +ERROR: bad-resolution-unit n ; +: lookup-resolution-unit ( n -- object ) + { + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } + [ bad-resolution-unit ] + } case ; + +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; +ERROR: bad-predictor n ; +: lookup-predictor ( n -- object ) + { + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } + [ bad-predictor ] + } case ; + +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; +ERROR: bad-planar-configuration n ; +: lookup-planar-configuration ( n -- object ) + { + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; + +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; +ERROR: bad-sample-format n ; +: lookup-sample-format ( sequence -- object ) + [ + { + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; +ERROR: bad-extra-samples n ; +: lookup-extra-samples ( sequence -- object ) + { + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; + +ERROR: bad-tiff-magic bytes ; +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> ?at [ no-tag ] unless ; + +: read-strips ( ifd -- ifd ) + dup + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; + +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + +: ifd-entry-value ( ifd-entry -- n ) + dup value-length 4 <= [ + adjust-offset/value + ] [ + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj + ] if ; + +: process-ifd-entry ( ifd-entry -- value class ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] + } case ; + +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; + +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; + +: ifd>image ( ifd -- image ) + { + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum ] + [ buffer>> ] + } cleave tiff-image new-image ; + +: parsed-tiff>images ( tiff -- sequence ) + ifds>> [ ifd>image ] map ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop binary [ + + read-header dup endianness>> [ + read-ifds + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + ] with-endianness + ] with-file-reader + parsed-tiff>images first ; diff --git a/extra/images/viewer/authors.txt b/extra/images/viewer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/viewer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor new file mode 100644 index 0000000000..4d5df4874a --- /dev/null +++ b/extra/images/viewer/viewer.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators images.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render images.tiff sequences multiline +images.backend images io.pathnames strings ; +IN: images.viewer + +TUPLE: image-gadget < gadget { image image } ; + +GENERIC: draw-image ( image -- ) + +M: image-gadget pref-dim* + image>> + [ width>> ] [ height>> ] bi + [ abs ] bi@ 2array ; + +M: image-gadget draw-gadget* ( gadget -- ) + origin get [ image>> draw-image ] with-translation ; + +: ( image -- gadget ) + \ image-gadget new-gadget + swap >>image ; + +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + +M: bitmap-image draw-image ( bitmap -- ) + { + [ + height>> dup 0 < [ + drop + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 swap abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + ] + [ width>> abs ] + [ height>> abs ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +: image-window ( path -- gadget ) + [ dup ] [ open-window ] bi ; + +M: tiff-image draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + { + [ height>> ] + [ width>> ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +GENERIC: image. ( image -- ) + +M: string image. ( image -- ) gadget. ; + +M: pathname image. ( image -- ) gadget. ; + +M: image image. ( image -- ) gadget. ; From 4ff9557351d5026a84f31ad447dd1f9c4d3595b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:59 -0600 Subject: [PATCH 142/170] remove the grpahics vocab --- extra/graphics/authors.txt | 1 - extra/graphics/bitmap/authors.txt | 1 - extra/graphics/bitmap/bitmap-tests.factor | 30 -- extra/graphics/bitmap/bitmap.factor | 139 --------- extra/graphics/bitmap/test-images/1bit.bmp | Bin 1662 -> 0 bytes extra/graphics/bitmap/test-images/rgb4bit.bmp | Bin 5318 -> 0 bytes extra/graphics/bitmap/test-images/rgb8bit.bmp | Bin 11078 -> 0 bytes .../bitmap/test-images/thiswayup24.bmp | Bin 60054 -> 0 bytes extra/graphics/tags.txt | 1 - extra/graphics/tiff/authors.txt | 1 - extra/graphics/tiff/rgb.tiff | Bin 7916 -> 0 bytes extra/graphics/tiff/tiff-tests.factor | 11 - extra/graphics/tiff/tiff.factor | 271 ------------------ extra/graphics/viewer/authors.txt | 1 - extra/graphics/viewer/viewer.factor | 66 ----- 15 files changed, 522 deletions(-) delete mode 100644 extra/graphics/authors.txt delete mode 100755 extra/graphics/bitmap/authors.txt delete mode 100644 extra/graphics/bitmap/bitmap-tests.factor delete mode 100755 extra/graphics/bitmap/bitmap.factor delete mode 100644 extra/graphics/bitmap/test-images/1bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb4bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb8bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/thiswayup24.bmp delete mode 100644 extra/graphics/tags.txt delete mode 100755 extra/graphics/tiff/authors.txt delete mode 100755 extra/graphics/tiff/rgb.tiff delete mode 100755 extra/graphics/tiff/tiff-tests.factor delete mode 100755 extra/graphics/tiff/tiff.factor delete mode 100755 extra/graphics/viewer/authors.txt delete mode 100644 extra/graphics/viewer/viewer.factor diff --git a/extra/graphics/authors.txt b/extra/graphics/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/graphics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/authors.txt b/extra/graphics/bitmap/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/bitmap/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor deleted file mode 100644 index f8a125e855..0000000000 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: graphics.bitmap graphics.viewer io.encodings.binary -io.files io.files.unique kernel tools.test ; -IN: graphics.bitmap.tests - -: test-bitmap32-alpha ( -- path ) - "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; - -: test-bitmap24 ( -- path ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; - -: test-bitmap16 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; - -: test-bitmap8 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; - -: test-bitmap4 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; - -: test-bitmap1 ( -- path ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; - -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-bitmap ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor deleted file mode 100755 index f8008dc7c1..0000000000 --- a/extra/graphics/bitmap/bitmap.factor +++ /dev/null @@ -1,139 +0,0 @@ -! Copyright (C) 2007, 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary -io.files kernel libc macros math math.bitwise math.functions -namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes ; -IN: graphics.bitmap - -! Currently can only handle 24/32bit bitmaps. -! Handles row-reversed bitmaps (their height is negative) - -TUPLE: bitmap magic size reserved offset header-length width -height planes bit-count compression size-image -x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? -array ; - -: array-copy ( bitmap array -- bitmap array' ) - over size-image>> abs memory>byte-array ; - -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>array ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - -: 8bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; - -ERROR: bmp-not-supported n ; - -: raw-bitmap>array ( bitmap -- array ) - dup bit-count>> - { - { 32 [ color-index>> ] } - { 24 [ color-index>> ] } - { 16 [ bmp-not-supported ] } - { 8 [ 8bit>array ] } - { 4 [ bmp-not-supported ] } - { 2 [ bmp-not-supported ] } - { 1 [ bmp-not-supported ] } - } case >byte-array ; - -ERROR: bitmap-magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; - -: read2 ( -- n ) 2 read le> ; -: read4 ( -- n ) 4 read le> ; - -: parse-file-header ( bitmap -- bitmap ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - read4 >>size - read4 >>reserved - read4 >>offset ; - -: parse-bitmap-header ( bitmap -- bitmap ) - read4 >>header-length - read4 >>width - read4 >>height - read2 >>planes - read2 >>bit-count - read4 >>compression - read4 >>size-image - read4 >>x-pels - read4 >>y-pels - read4 >>color-used - read4 >>color-important ; - -: rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] [ header-length>> ] bi - ; - -: color-index-length ( bitmap -- n ) - { - [ width>> ] - [ planes>> * ] - [ bit-count>> * 31 + 32 /i 4 * ] - [ height>> abs * ] - } cleave ; - -: parse-bitmap ( bitmap -- bitmap ) - dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index ; - -: (load-bitmap) ( path -- bitmap ) - binary [ - bitmap new - parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader ; - -: alpha-channel-zero? ( bitmap -- ? ) - array>> 4 3 [ 0 = ] all? ; - -: load-bitmap ( path -- bitmap ) - (load-bitmap) - dup raw-bitmap>array >>array - dup alpha-channel-zero? >>alpha-channel-zero? ; - -: write2 ( n -- ) 2 >le write ; -: write4 ( n -- ) 4 >le write ; - -: save-bitmap ( bitmap path -- ) - binary [ - B{ CHAR: B CHAR: M } write - [ - array>> length 14 + 40 + write4 - 0 write4 - 54 write4 - 40 write4 - ] [ - { - [ width>> write4 ] - [ height>> write4 ] - [ planes>> 1 or write2 ] - [ bit-count>> 24 or write2 ] - [ compression>> 0 or write4 ] - [ size-image>> write4 ] - [ x-pels>> 0 or write4 ] - [ y-pels>> 0 or write4 ] - [ color-used>> 0 or write4 ] - [ color-important>> 0 or write4 ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave - ] bi - ] with-file-writer ; diff --git a/extra/graphics/bitmap/test-images/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp deleted file mode 100644 index 2f244c1d058bfd63c99009e24e43db3d2af59902..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| diff --git a/extra/graphics/bitmap/test-images/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp deleted file mode 100644 index 0c6f00d06c025f6947899450afd91ace50e5b57a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor deleted file mode 100755 index f800b4d213..0000000000 --- a/extra/graphics/tiff/tiff-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test graphics.tiff ; -IN: graphics.tiff.tests - -: tiff-test-path ( -- path ) - "resource:extra/graphics/tiff/rgb.tiff" ; - -: tiff-test-path2 ( -- path ) - "resource:extra/graphics/tiff/octagon.tiff" ; - diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor deleted file mode 100755 index 0481af8747..0000000000 --- a/extra/graphics/tiff/tiff.factor +++ /dev/null @@ -1,271 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes -io.binary assocs math math.bitwise byte-arrays grouping ; -IN: graphics.tiff - -TUPLE: tiff endianness the-answer ifd-offset ifds ; - -CONSTRUCTOR: tiff ( -- tiff ) - V{ } clone >>ifds ; - -TUPLE: ifd count ifd-entries next -processed-tags strips buffer ; -CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; - -TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -SINGLETONS: photometric-interpretation -photometric-interpretation-white-is-zero -photometric-interpretation-black-is-zero -photometric-interpretation-rgb -photometric-interpretation-palette-color ; -ERROR: bad-photometric-interpretation n ; -: lookup-photometric-interpretation ( n -- singleton ) - { - { 0 [ photometric-interpretation-white-is-zero ] } - { 1 [ photometric-interpretation-black-is-zero ] } - { 2 [ photometric-interpretation-rgb ] } - { 3 [ photometric-interpretation-palette-color ] } - [ bad-photometric-interpretation ] - } case ; - -SINGLETONS: compression -compression-none -compression-CCITT-2 -compression-lzw -compression-pack-bits ; -ERROR: bad-compression n ; -: lookup-compression ( n -- compression ) - { - { 1 [ compression-none ] } - { 2 [ compression-CCITT-2 ] } - { 5 [ compression-lzw ] } - { 32773 [ compression-pack-bits ] } - [ bad-compression ] - } case ; - -SINGLETONS: resolution-unit -resolution-unit-none -resolution-unit-inch -resolution-unit-centimeter ; -ERROR: bad-resolution-unit n ; -: lookup-resolution-unit ( n -- object ) - { - { 1 [ resolution-unit-none ] } - { 2 [ resolution-unit-inch ] } - { 3 [ resolution-unit-centimeter ] } - [ bad-resolution-unit ] - } case ; - -SINGLETONS: predictor -predictor-none -predictor-horizontal-differencing ; -ERROR: bad-predictor n ; -: lookup-predictor ( n -- object ) - { - { 1 [ predictor-none ] } - { 2 [ predictor-horizontal-differencing ] } - [ bad-predictor ] - } case ; - -SINGLETONS: planar-configuration -planar-configuration-chunky -planar-configuration-planar ; -ERROR: bad-planar-configuration n ; -: lookup-planar-configuration ( n -- object ) - { - { 1 [ planar-configuration-chunky ] } - { 2 [ planar-configuration-planar ] } - [ bad-planar-configuration ] - } case ; - -ERROR: bad-sample-format n ; -SINGLETONS: sample-format -sample-format-unsigned-integer -sample-format-signed-integer -sample-format-ieee-float -sample-format-undefined-data ; -: lookup-sample-format ( seq -- object ) - [ - { - { 1 [ sample-format-unsigned-integer ] } - { 2 [ sample-format-signed-integer ] } - { 3 [ sample-format-ieee-float ] } - { 4 [ sample-format-undefined-data ] } - [ bad-sample-format ] - } case - ] map ; - -ERROR: bad-extra-samples n ; -SINGLETONS: extra-samples -extra-samples-unspecified-alpha-data -extra-samples-associated-alpha-data -extra-samples-unassociated-alpha-data ; -: lookup-extra-samples ( seq -- object ) - { - { 0 [ extra-samples-unspecified-alpha-data ] } - { 1 [ extra-samples-associated-alpha-data ] } - { 2 [ extra-samples-unassociated-alpha-data ] } - [ bad-extra-samples ] - } case ; - -SINGLETONS: image-length image-width x-resolution y-resolution -rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; - -ERROR: bad-tiff-magic bytes ; -: tiff-endianness ( byte-array -- ? ) - { - { B{ CHAR: M CHAR: M } [ big-endian ] } - { B{ CHAR: I CHAR: I } [ little-endian ] } - [ bad-tiff-magic ] - } case ; - -: read-header ( tiff -- tiff ) - 2 read tiff-endianness [ >>endianness ] keep - [ - 2 read endian> >>the-answer - 4 read endian> >>ifd-offset - ] with-endianness ; - -: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; - -: read-ifd ( -- ifd ) - 2 read endian> - 2 read endian> - 4 read endian> - 4 read endian> ; - -: read-ifds ( tiff -- tiff ) - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; - -ERROR: no-tag class ; - -: ?at ( key assoc -- value/key ? ) - dupd at* [ nip t ] [ drop f ] if ; inline - -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; - -: read-strips ( ifd -- ifd ) - dup - [ strip-byte-counts find-tag ] - [ strip-offsets find-tag ] bi - 2dup [ integer? ] both? [ - seek-absolute seek-input read 1array - ] [ - [ seek-absolute seek-input read ] { } 2map-as - ] if >>strips ; - -ERROR: unknown-ifd-type n ; - -: bytes>bits ( n/byte-array -- n ) - dup byte-array? [ byte-array>bignum ] when ; - -: value-length ( ifd-entry -- n ) - [ count>> ] [ type>> ] bi { - { 1 [ ] } - { 2 [ ] } - { 3 [ 2 * ] } - { 4 [ 4 * ] } - { 5 [ 8 * ] } - { 6 [ ] } - { 7 [ ] } - { 8 [ 2 * ] } - { 9 [ 4 * ] } - { 10 [ 8 * ] } - { 11 [ 4 * ] } - { 12 [ 8 * ] } - [ unknown-ifd-type ] - } case ; - -ERROR: bad-small-ifd-type n ; - -: adjust-offset/value ( ifd-entry -- obj ) - [ offset/value>> 4 >endian ] [ type>> ] bi - { - { 1 [ 1 head endian> ] } - { 3 [ 2 head endian> ] } - { 4 [ endian> ] } - { 6 [ 1 head endian> 8 >signed ] } - { 8 [ 2 head endian> 16 >signed ] } - { 9 [ endian> 32 >signed ] } - { 11 [ endian> bits>float ] } - [ bad-small-ifd-type ] - } case ; - -: offset-bytes>obj ( bytes type -- obj ) - { - { 1 [ ] } ! blank - { 2 [ ] } ! read c strings here - { 3 [ 2 [ endian> ] map ] } - { 4 [ 4 [ endian> ] map ] } - { 5 [ 8 [ "II" unpack first2 / ] map ] } - { 6 [ [ 8 >signed ] map ] } - { 7 [ ] } ! blank - { 8 [ 2 [ endian> 16 >signed ] map ] } - { 9 [ 4 [ endian> 32 >signed ] map ] } - { 10 [ 8 group [ "ii" unpack first2 / ] map ] } - { 11 [ 4 group [ "f" unpack ] map ] } - { 12 [ 8 group [ "d" unpack ] map ] } - [ unknown-ifd-type ] - } case ; - -: ifd-entry-value ( ifd-entry -- n ) - dup value-length 4 <= [ - adjust-offset/value - ] [ - [ offset/value>> seek-absolute seek-input ] - [ value-length read ] - [ type>> ] tri offset-bytes>obj - ] if ; - -: process-ifd-entry ( ifd-entry -- value class ) - [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ new-subfile-type ] } - { 256 [ image-width ] } - { 257 [ image-length ] } - { 258 [ bits-per-sample ] } - { 259 [ lookup-compression compression ] } - { 262 [ lookup-photometric-interpretation photometric-interpretation ] } - { 273 [ strip-offsets ] } - { 274 [ orientation ] } - { 277 [ samples-per-pixel ] } - { 278 [ rows-per-strip ] } - { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } - { 284 [ planar-configuration ] } - { 296 [ lookup-resolution-unit resolution-unit ] } - { 317 [ lookup-predictor predictor ] } - { 338 [ lookup-extra-samples extra-samples ] } - { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] - } case ; - -: process-ifd ( ifd -- ifd ) - dup ifd-entries>> - [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; - -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; - -: (load-tiff) ( path -- tiff ) - binary [ - - read-header dup endianness>> [ - read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-endianness - ] with-file-reader ; - -: load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/authors.txt b/extra/graphics/viewer/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/viewer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor deleted file mode 100644 index 517ab4e010..0000000000 --- a/extra/graphics/viewer/viewer.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators graphics.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render graphics.tiff sequences ; -IN: graphics.viewer - -TUPLE: graphics-gadget < gadget image ; - -GENERIC: draw-image ( image -- ) -GENERIC: width ( image -- w ) -GENERIC: height ( image -- h ) - -M: graphics-gadget pref-dim* - image>> [ width ] keep height abs 2array ; - -M: graphics-gadget draw-gadget* ( gadget -- ) - origin get [ image>> draw-image ] with-translation ; - -: ( bitmap -- gadget ) - \ graphics-gadget new-gadget - swap >>image ; - -: bits>gl-params ( n -- gl-bgr gl-format ) - { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> bits>gl-params - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; - -M: tiff draw-image ( tiff -- ) - [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip - ifds>> first - { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum bits>gl-params ] - [ buffer>> ] - } cleave glDrawPixels ; From 72b343ce03c39b765926de373eee0aee12dbf9b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:15:57 -0600 Subject: [PATCH 143/170] fix images tests --- extra/images/bitmap/bitmap-tests.factor | 13 +++++-------- extra/images/bitmap/bitmap.factor | 11 ++++++++--- extra/images/tiff/tiff-tests.factor | 5 ++--- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index 6865bfee3c..a2b3188749 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -2,23 +2,20 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test ; IN: images.bitmap.tests -: test-bitmap32-alpha ( -- path ) - "resource:extra/images/bitmap/test-images/32alpha.bmp" ; - : test-bitmap24 ( -- path ) - "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + "resource:extra/images/test-images/thiswayup24.bmp" ; : test-bitmap16 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + "resource:extra/images/test-images/rgb16bit.bmp" ; : test-bitmap8 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + "resource:extra/images/test-images/rgb8bit.bmp" ; : test-bitmap4 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + "resource:extra/images/test-images/rgb4bit.bmp" ; : test-bitmap1 ( -- path ) - "resource:extra/images/bitmap/test-images/1bit.bmp" ; + "resource:extra/images/test-images/1bit.bmp" ; [ t ] [ diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 220cdc153f..eb31dcd385 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,7 +97,7 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap ( path -- bitmap ) +: load-bitmap-data ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap @@ -106,14 +106,19 @@ M: bitmap-magic summary : alpha-channel-zero? ( bitmap -- ? ) buffer>> 4 3 [ 0 = ] all? ; +: process-bitmap-data ( bitmap -- bitmap ) + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? ; + +: load-bitmap ( path -- bitmap ) + load-bitmap-data process-bitmap-data ; + : bitmap>image ( bitmap -- bitmap-image ) { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? bitmap>image ; : write2 ( n -- ) 2 >le write ; diff --git a/extra/images/tiff/tiff-tests.factor b/extra/images/tiff/tiff-tests.factor index dcc4b05eab..9905e7ad79 100755 --- a/extra/images/tiff/tiff-tests.factor +++ b/extra/images/tiff/tiff-tests.factor @@ -4,8 +4,7 @@ USING: tools.test images.tiff ; IN: images.tiff.tests : tiff-test-path ( -- path ) - "resource:extra/images/tiff/rgb.tiff" ; + "resource:extra/images/test-images/rgb.tiff" ; : tiff-test-path2 ( -- path ) - "resource:extra/images/tiff/octagon.tiff" ; - + "resource:extra/images/test-images/octagon.tiff" ; From d887ff67888bd42e1ebecfd0a1316b90dbed9d5e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:26:52 -0600 Subject: [PATCH 144/170] fix screen capture --- extra/cap/cap.factor | 4 ++-- extra/images/bitmap/bitmap.factor | 32 +++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 716435775d..1f62441028 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces -opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer +opengl.gl sequences math.vectors ui images.bitmap images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap @@ -27,4 +27,4 @@ IN: cap [ screenshot ] dip save-bitmap ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index eb31dcd385..50975b2bb3 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -21,22 +21,6 @@ buffer ; : array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - : 8bit>buffer ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; @@ -121,6 +105,22 @@ M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap bitmap>image ; +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count bitmap>image + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; From e82f3a8518cef06407e9a3fd128eb8ef2f638eb6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:40:29 -0600 Subject: [PATCH 145/170] update ui.offscreen and ui.render --- extra/ui/offscreen/offscreen.factor | 2 +- extra/ui/render/test/test.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 89c1c7f860..cf9370ed7f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ ! (c) 2008 Joe Groff, see license for details -USING: accessors continuations graphics.bitmap kernel math +USING: accessors continuations images.bitmap kernel math sequences ui.gadgets ui.gadgets.worlds ui ui.backend destructors ; IN: ui.offscreen diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index 2267c22a20..dcbc5b9600 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors arrays kernel sequences math byte-arrays -namespaces grouping fry cap graphics.bitmap +namespaces grouping fry cap images.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons -ui.render ui opengl opengl.gl ; +ui.render ui opengl opengl.gl images ; IN: ui.render.test SINGLETON: line-test @@ -30,7 +30,7 @@ SYMBOL: render-output : bitmap= ( bitmap1 bitmap2 -- ? ) [ - [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi + [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi '[ _ head twiddle ] map ] bi@ = ; @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" load-bitmap + "resource:extra/ui/render/test/reference.bmp" bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window From 064e4c8d0969e325ed3ed58624e46ec13e25895d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:41:07 -0600 Subject: [PATCH 146/170] update offscreen docs --- extra/ui/offscreen/offscreen-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 5d800981bf..4123a83675 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations ui.gadgets -graphics.bitmap strings ui.gadgets.worlds ; +images.bitmap strings ui.gadgets.worlds ; IN: ui.offscreen HELP: From 9f49b19306c89e5c692e21cc19e440d8c9baed99 Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 21:50:04 -0600 Subject: [PATCH 147/170] Added extra/id3 vocab --- extra/id3/authors.txt | 0 extra/id3/id3-docs.factor | 10 ++ extra/id3/id3-tests.factor | 182 +++++++++++++++++++++++++++++++++++++ extra/id3/id3.factor | 154 +++++++++++++++++++++++++++++++ extra/id3/tests/blah.mp3 | Bin 0 -> 145 bytes extra/id3/tests/blah2.mp3 | Bin 0 -> 400 bytes extra/id3/tests/blah3.mp3 | Bin 0 -> 300 bytes 7 files changed, 346 insertions(+) create mode 100644 extra/id3/authors.txt create mode 100644 extra/id3/id3-docs.factor create mode 100644 extra/id3/id3-tests.factor create mode 100644 extra/id3/id3.factor create mode 100644 extra/id3/tests/blah.mp3 create mode 100644 extra/id3/tests/blah2.mp3 create mode 100644 extra/id3/tests/blah3.mp3 diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor new file mode 100644 index 0000000000..1c77967ed1 --- /dev/null +++ b/extra/id3/id3-docs.factor @@ -0,0 +1,10 @@ +IN: id3 +USING: help.markup help.syntax sequences kernel ; + +HELP: id3-parse-mp3-file +{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } + +ARTICLE: "id3" "ID3 tags" +{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" + +ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor new file mode 100644 index 0000000000..d84f2c8726 --- /dev/null +++ b/extra/id3/id3-tests.factor @@ -0,0 +1,182 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test id3 ; +IN: id3.tests + +[ T{ mp3v2-file + { header T{ header f t 0 502 } } + { frames + { + T{ frame + { frame-id "COMM" } + { flags B{ 0 0 } } + { size 19 } + { data "eng, AG# 08E1C12E" } + } + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 15 } + { data "Stormy Weather" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 3 } + { data "32" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 5 } + { data "(96)" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 28 } + { data "Night and Day Frank Sinatra" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 39 } + { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 41 } + { data "WM/MediaClassSecondaryID" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 14 } + { data "Frank Sinatra" } + } + } + } +} +] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v2-file + { header + T{ header { version t } { flags 0 } { size 1405 } } + } + { frames + { + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 22 } + { data "Anthem of the Trinity" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 12 } + { data "Terry Riley" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 11 } + { data "Shri Camel" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 10 } + { data "Classical" } + } + T{ frame + { frame-id "UFID" } + { flags B{ 0 0 } } + { size 23 } + { data "http://musicbrainz.org" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 23 } + { data "MusicBrainz Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "musicbrainz_artistid" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "MusicBrainz Album Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 21 } + { data "musicbrainz_albumid" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 29 } + { data "MusicBrainz Album Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 27 } + { data "musicbrainz_albumartistid" } + } + T{ frame + { frame-id "TPOS" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TSOP" } + { flags B{ 0 0 } } + { size 1 } + } + T{ frame + { frame-id "TMED" } + { flags B{ 0 0 } } + { size 4 } + { data "DIG" } + } + } + } +} +] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v1-file + { title + "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { artist + "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { album + "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { year "2009" } + { comment + "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { genre 89 } + } +] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test + diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor new file mode 100644 index 0000000000..b2c2ec0621 --- /dev/null +++ b/extra/id3/id3.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +IN: id3 + +! tuples + +TUPLE: header version flags size ; + +TUPLE: frame frame-id flags size data ; + +TUPLE: mp3v2-file header frames ; + +TUPLE: mp3v1-file title artist album year comment genre ; + +: ( -- object ) mp3v1-file new ; + +: ( header frames -- object ) mp3v2-file boa ; + +:
( -- object ) header new ; + +: ( -- object ) frame new ; + +28bitword ( seq -- int ) + 0 [ swap 7 shift bitor ] reduce ; + +: filter-text-data ( data -- filtered ) + [ printable? ] filter ; + +! frame details stuff + +: valid-frame-id? ( id -- ? ) + [ [ digit? ] [ LETTER? ] bi or ] all? ; + +: read-frame-id ( mmap -- id ) + 4 head-slice ; + +: read-frame-size ( mmap -- size ) + [ 4 8 ] dip subseq ; + +: read-frame-flags ( mmap -- flags ) + [ 8 10 ] dip subseq ; + +: read-frame-data ( frame mmap -- frame data ) + [ 10 over size>> 10 + ] dip filter-text-data ; + +! read whole frames + +: (read-frame) ( mmap -- frame ) + [ ] dip + { + [ read-frame-id ascii decode >>frame-id ] + [ read-frame-flags >byte-array >>flags ] + [ read-frame-size >28bitword >>size ] + [ read-frame-data ascii decode >>data ] + } cleave ; + +: read-frame ( mmap -- frame/f ) + dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ; + +: remove-frame ( mmap frame -- mmap ) + size>> 10 + tail-slice ; + +: read-frames ( mmap -- frames ) + [ dup read-frame dup ] + [ [ remove-frame ] keep ] + [ drop ] produce nip ; + +! header stuff + +: read-header-supported-version? ( mmap -- ? ) + 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ; + +: read-header-flags ( mmap -- flags ) + 5 swap nth ; + +: read-header-size ( mmap -- size ) + [ 6 10 ] dip >28bitword ; + +: read-v2-header ( mmap -- id3header ) + [
] dip + { + [ read-header-supported-version? >>version ] + [ read-header-flags >>flags ] + [ read-header-size >>size ] + } cleave ; + +: drop-header ( mmap -- seq1 seq2 ) + dup 10 tail-slice swap ; + +: read-v2-tag-data ( seq -- mp3v2-file ) + drop-header read-v2-header swap read-frames ; + +! v1 information + +: skip-to-v1-data ( seq -- seq ) + 125 tail-slice* ; + +: read-title ( seq -- title ) + 30 head-slice ; + +: read-artist ( seq -- title ) + [ 30 60 ] dip subseq ; + +: read-album ( seq -- album ) + [ 60 90 ] dip subseq ; + +: read-year ( seq -- year ) + [ 90 94 ] dip subseq ; + +: read-comment ( seq -- comment ) + [ 94 124 ] dip subseq ; + +: read-genre ( seq -- genre ) + [ 124 ] dip nth ; + +: (read-v1-tag-data) ( seq -- mp3-file ) + [ ] dip + { + [ read-title ascii decode >>title ] + [ read-artist ascii decode >>artist ] + [ read-album ascii decode >>album ] + [ read-year ascii decode >>year ] + [ read-comment ascii decode >>comment ] + [ read-genre >fixnum >>genre ] + } cleave ; + +: read-v1-tag-data ( seq -- mp3-file ) + skip-to-v1-data (read-v1-tag-data) ; + +PRIVATE> + +! main stuff + +: id3-parse-mp3-file ( path -- object ) + [ + { + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + [ drop f ] ! ( mmap -- f ) + } cond + ] with-mapped-uchar-file ; + +! end diff --git a/extra/id3/tests/blah.mp3 b/extra/id3/tests/blah.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..3a60bffd340b9c8c0620dacefa74910529ad2b5e GIT binary patch literal 145 zcmZQzKm#F;?oK|A9%!OST*sgg&)^Uw0TiaAk5i~GiU=~t$iTqT+27aK)en~ekpNBc B2y*}c literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah2.mp3 b/extra/id3/tests/blah2.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..5d274299820c2dbab156db61c5e52bb83fc4fc80 GIT binary patch literal 400 zcmZutv2MaJ6m*+Tl(l6*NdAH%=*AWjKo-zM#7NnYQv$K%1mu_@Nc?-xq^J~li=Xc9 zolnR7&liGeoH*lsEboLkZeg-Cr@IZsOSzVXG!+j=J@8HNJk`3Q3#rnIyR#wCSD;a* zCG|v}D((ee))SzoL|Mvjp_XIj18WhI8M7aByZHflqJ=DuA3MDzJdWd9K<1Vjo+;{T zBTGZs`XWF;a&@~BXMqI2@TTCN@oVqb%xeFcspODfdA;3wS>9UJSvn8T?-I2ix%|Zn ag9w5;RuqKTpKOQok?jNJJ3gCWtLFzj*kz#r literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah3.mp3 b/extra/id3/tests/blah3.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..19aaa94dc692ddbd4d329d6e073609bdda0cd6dd GIT binary patch literal 300 zcmeZtF=l1}0_HMje_vl9Ll}rt^U@h~6dc`^6$~s~4V?{*TthrVjDQmSKpb3>UzA&^ z5T2S?l95^z66EX+6a<-JY!u?`?+0YC0Ow^E~4K literal 0 HcmV?d00001 From 17724be48c5a8d3ba0a4a6126663d5cb0dc632e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:44 -0600 Subject: [PATCH 148/170] factor out a load-tiff word --- extra/images/tiff/tiff.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index a220475081..4be81af095 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -271,13 +271,15 @@ ERROR: bad-small-ifd-type n ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; -! tiff files can store several images -- we just take the first for now -M: tiff-image load-image* ( path tiff-image -- image ) - drop binary [ +: load-tiff ( path -- parsed-tiff ) + binary [ read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-endianness - ] with-file-reader - parsed-tiff>images first ; + ] with-file-reader ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop load-tiff parsed-tiff>images first ; From e5e98cc5cb348431743058125e6fe06e4e7245ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:58 -0600 Subject: [PATCH 149/170] undo load breakage --- extra/taxes/usa/usa.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index efdb969c01..bbfc332868 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals namespaces sequences money math.order taxes.usa.w4 -taxes.usa.futa math.finance taxes.usa.fica -taxes.usa.federal ; +taxes.usa.futa math.finance ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) From 204f5195f708b459cf176b1cc24366f93acb51fd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 22:08:35 -0600 Subject: [PATCH 150/170] mark blas libs unportable till i sort out all the fortran abis --- basis/alien/fortran/tags.txt | 1 + basis/math/blas/ffi/tags.txt | 1 + basis/math/blas/matrices/tags.txt | 1 + basis/math/blas/vectors/tags.txt | 2 ++ 4 files changed, 5 insertions(+) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 2a9b5def7a..58465edeb5 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,2 +1,3 @@ fortran ffi +unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index f468a9989d..a4a4ea88ab 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,3 +1,4 @@ math bindings fortran +unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 241ec1ecda..5118958180 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,2 +1,3 @@ math bindings +unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index ede10ab61b..5118958180 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1 +1,3 @@ math +bindings +unportable From 0ba4a08ea95d23c1970c15af06e2d897073b0e7f Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 22:38:27 -0600 Subject: [PATCH 151/170] Fixed authors.txt and id3-docs --- extra/id3/authors.txt | 2 ++ extra/id3/id3-docs.factor | 13 ++++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt index e69de29bb2..ece617b969 100644 --- a/extra/id3/authors.txt +++ b/extra/id3/authors.txt @@ -0,0 +1,2 @@ +Tim Wawrzynczak + diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 1c77967ed1..94128dc3b2 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,10 +1,17 @@ -IN: id3 +! Copyright (C) 2008 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax sequences kernel ; +IN: id3 HELP: id3-parse-mp3-file -{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } +{ $values + { "path" "a path string" } + { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; ARTICLE: "id3" "ID3 tags" -{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +"Parsing an MP3 file: " +{ $subsection id3-parse-mp3-file } ; ABOUT: "id3" From c51a5d7678c365a87981c1df1b05d51ecb589e97 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 10 Feb 2009 01:46:02 -0600 Subject: [PATCH 152/170] Making basis/wrap not try to align the last line --- basis/wrap/strings/strings-tests.factor | 4 +++- basis/wrap/wrap.factor | 6 ++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index 0bea9b5d32..e66572dc1b 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -27,7 +27,7 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots\nof spaces" ] +[ "this text\nhas lots of\nspaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] @@ -39,3 +39,5 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer + +[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 6e5bf31075..0b7f869141 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -36,8 +36,10 @@ SYMBOL: line-ideal ] each drop ; inline : paragraph-cost ( paragraph -- cost ) - [ head-width>> deviation ] - [ tail-cost>> ] bi + ; + dup lines>> 1list? [ drop 0 ] [ + [ head-width>> deviation ] + [ tail-cost>> ] bi + + ] if ; : min-cost ( paragraphs -- paragraph ) [ paragraph-cost ] min-by ; From bac9705da1e9bbd13953461c0d6bcc67ff2551e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 10:37:46 -0600 Subject: [PATCH 153/170] spiff up id3 docs a bit, and fix help-lint --- extra/id3/id3-docs.factor | 12 ++++++------ extra/id3/id3-tests.factor | 6 +++--- extra/id3/id3.factor | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 94128dc3b2..da69c2ced3 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -3,15 +3,15 @@ USING: help.markup help.syntax sequences kernel ; IN: id3 -HELP: id3-parse-mp3-file +HELP: file-id3-tags { $values { "path" "a path string" } - { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; + { "object/f" "a tuple storing ID3 metadata or f" } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; ARTICLE: "id3" "ID3 tags" -{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" -"Parsing an MP3 file: " -{ $subsection id3-parse-mp3-file } ; +"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl +"Parsing ID3 tags from an MP3 file:" +{ $subsection file-id3-tags } ; ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index d84f2c8726..b9d45b1b04 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -58,7 +58,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test [ T{ mp3v2-file @@ -159,7 +159,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ T{ mp3v1-file @@ -178,5 +178,5 @@ IN: id3.tests } { genre 89 } } -] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index b2c2ec0621..64e1ff1d10 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -142,7 +142,7 @@ PRIVATE> ! main stuff -: id3-parse-mp3-file ( path -- object ) +: file-id3-tags ( path -- object/f ) [ { { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) From 1708d10c9a94e0af4ac1da04c0494aafc0fa33cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:02:33 -0600 Subject: [PATCH 154/170] add initialize word to namespaces. foo global [ [ bar ] unless* ] curry => foo [ bar ] initialize --- core/namespaces/namespaces-docs.factor | 9 +++++++-- core/namespaces/namespaces-tests.factor | 11 +++++++++++ core/namespaces/namespaces.factor | 5 ++++- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 1cc3d86e98..ff0542a7b8 100644 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math ; +math.parser math words.symbol ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -20,7 +20,8 @@ ARTICLE: "namespaces-global" "Global variables" { $subsection namespace } { $subsection global } { $subsection get-global } -{ $subsection set-global } ; +{ $subsection set-global } +{ $subsection initialize } ; ARTICLE: "namespaces.private" "Namespace implementation details" "The namestack holds namespaces." @@ -159,3 +160,7 @@ HELP: ndrop HELP: init-namespaces { $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } $low-level-note ; + +HELP: initialize +{ $values { "variable" symbol } { "quot" quotation } } +{ $description "If " { $snippet "variable" } " does not have a value in the global namespace, calls " { $snippet "quot" } " and assigns the result to " { $snippet "variable" } " in the global namespace." } ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 4c11e2389f..616ddef7fc 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -12,3 +12,14 @@ H{ } clone "test-namespace" set [ f ] [ H{ } clone [ f "some-global" set "some-global" get ] bind ] unit-test + +SYMBOL: test-initialize +test-initialize [ 1 ] initialize +test-initialize [ 2 ] initialize + +[ 1 ] [ test-initialize get-global ] unit-test + +f test-initialize set-global +test-initialize [ 5 ] initialize + +[ 5 ] [ test-initialize get-global ] unit-test diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 36559095cb..24095fd382 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -37,4 +37,7 @@ PRIVATE> H{ } clone >n call ndrop ; inline : with-variable ( value key quot -- ) - [ associate >n ] dip call ndrop ; inline + [ associate >n ] dip call ndrop ; inline + +: initialize ( variable quot -- ) + [ global ] [ [ unless* ] curry ] bi* change-at ; From 8a144b7b948d72239b484dabeefc016bf9c1ea58 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:11:06 -0600 Subject: [PATCH 155/170] support different fortran ABIs --- basis/alien/fortran/fortran-docs.factor | 27 +- basis/alien/fortran/fortran-tests.factor | 546 +++++++++++++---------- basis/alien/fortran/fortran.factor | 92 +++- basis/math/blas/ffi/ffi.factor | 8 +- 4 files changed, 418 insertions(+), 255 deletions(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 4accbf5965..c5d124e198 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -1,9 +1,19 @@ ! Copyright (C) 2009 Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations sequences strings ; +USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; QUALIFIED-WITH: alien.syntax c IN: alien.fortran +ARTICLE: "alien.fortran-abis" "Fortran ABIs" +"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:" +{ $list + { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." } + { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." } + { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." } + { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." } +} +"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ; + ARTICLE: "alien.fortran-types" "Fortran types" "The Fortran FFI recognizes the following Fortran types:" { $list @@ -15,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types" { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } - { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } } "When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; @@ -30,15 +40,20 @@ HELP: SUBROUTINE: HELP: LIBRARY: { $syntax "LIBRARY: name" } { $values { "name" "a logical library name" } } -{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ; +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; HELP: RECORD: { $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } -{ $description "Defines a Fortran record type with the given slots." } ; +{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; + +HELP: add-fortran-library +{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } } +{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } +; HELP: fortran-invoke { $values - { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } } { $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } ; @@ -46,6 +61,8 @@ HELP: fortran-invoke ARTICLE: "alien.fortran" "Fortran FFI" "The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." { $subsection "alien.fortran-types" } +{ $subsection "alien.fortran-abis" } +{ $subsection add-fortran-library } { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } { $subsection POSTPONE: SUBROUTINE: } diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 1b2ffda4a9..177d1077c2 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,295 +1,381 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex -alien.fortran alien.strings alien.structs alien.syntax arrays -assocs byte-arrays combinators fry generalizations -io.encodings.ascii kernel macros macros.expander namespaces -sequences shuffle tools.test ; +alien.fortran alien.fortran.private alien.strings alien.structs +arrays assocs byte-arrays combinators fry +generalizations io.encodings.ascii kernel macros +macros.expander namespaces sequences shuffle tools.test ; IN: alien.fortran.tests +<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> +LIBRARY: (alien.fortran-tests) RECORD: FORTRAN_TEST_RECORD { "INTEGER" "FOO" } { "REAL(2)" "BAR" } { "CHARACTER*4" "BAS" } ; -! fortran-name>symbol-name +intel-unix-abi fortran-abi [ -[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test -[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test -[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + ! fortran-name>symbol-name -! fortran-type>c-type + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test -[ "short" ] -[ "integer*2" fortran-type>c-type ] unit-test + ! fortran-type>c-type -[ "int" ] -[ "integer*4" fortran-type>c-type ] unit-test + [ "short" ] + [ "integer*2" fortran-type>c-type ] unit-test -[ "int" ] -[ "INTEGER" fortran-type>c-type ] unit-test + [ "int" ] + [ "integer*4" fortran-type>c-type ] unit-test -[ "longlong" ] -[ "iNteger*8" fortran-type>c-type ] unit-test + [ "int" ] + [ "INTEGER" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(*)" fortran-type>c-type ] unit-test + [ "longlong" ] + [ "iNteger*8" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(3,*)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(*)" fortran-type>c-type ] unit-test -[ "int[3]" ] -[ "integer(3)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(3,*)" fortran-type>c-type ] unit-test -[ "int[6]" ] -[ "integer(3,2)" fortran-type>c-type ] unit-test + [ "int[3]" ] + [ "integer(3)" fortran-type>c-type ] unit-test -[ "int[24]" ] -[ "integer(4,3,2)" fortran-type>c-type ] unit-test + [ "int[6]" ] + [ "integer(3,2)" fortran-type>c-type ] unit-test -[ "char[1]" ] -[ "character" fortran-type>c-type ] unit-test + [ "int[24]" ] + [ "integer(4,3,2)" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character*17" fortran-type>c-type ] unit-test + [ "char" ] + [ "character" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character(17)" fortran-type>c-type ] unit-test + [ "char" ] + [ "character*1" fortran-type>c-type ] unit-test -[ "int" ] -[ "logical" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character*17" fortran-type>c-type ] unit-test -[ "float" ] -[ "real" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character(17)" fortran-type>c-type ] unit-test -[ "double" ] -[ "double-precision" fortran-type>c-type ] unit-test + [ "int" ] + [ "logical" fortran-type>c-type ] unit-test -[ "float" ] -[ "real*4" fortran-type>c-type ] unit-test + [ "float" ] + [ "real" fortran-type>c-type ] unit-test -[ "double" ] -[ "real*8" fortran-type>c-type ] unit-test + [ "double" ] + [ "double-precision" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex" fortran-type>c-type ] unit-test + [ "float" ] + [ "real*4" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "double-complex" fortran-type>c-type ] unit-test + [ "double" ] + [ "real*8" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex*8" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "complex*16" fortran-type>c-type ] unit-test + [ "complex-double" ] + [ "double-complex" fortran-type>c-type ] unit-test -[ "fortran_test_record" ] -[ "fortran_test_record" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex*8" fortran-type>c-type ] unit-test -! fortran-arg-type>c-type + [ "complex-double" ] + [ "complex*16" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record" ] + [ "fortran_test_record" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer(3)" fortran-arg-type>c-type ] unit-test + ! fortran-arg-type>c-type -[ "int*" { } ] -[ "integer(*)" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer" fortran-arg-type>c-type ] unit-test -[ "fortran_test_record*" { } ] -[ "fortran_test_record" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer(3)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character(17)" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record*" { } ] + [ "fortran_test_record" fortran-arg-type>c-type ] unit-test -! fortran-ret-type>c-type + [ "char*" { } ] + [ "character" fortran-arg-type>c-type ] unit-test -[ "void" { "char*" "long" } ] -[ "character(17)" fortran-ret-type>c-type ] unit-test + [ "char*" { } ] + [ "character(1)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "integer" fortran-ret-type>c-type ] unit-test + [ "char*" { "long" } ] + [ "character(17)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "logical" fortran-ret-type>c-type ] unit-test + ! fortran-ret-type>c-type -[ "float" { } ] -[ "real" fortran-ret-type>c-type ] unit-test + [ "char" { } ] + [ "character(1)" fortran-ret-type>c-type ] unit-test -[ "double" { } ] -[ "double-precision" fortran-ret-type>c-type ] unit-test + [ "void" { "char*" "long" } ] + [ "character(17)" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" } ] -[ "complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "integer" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-double*" } ] -[ "double-complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "logical" fortran-ret-type>c-type ] unit-test -[ "void" { "int*" } ] -[ "integer(*)" fortran-ret-type>c-type ] unit-test + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test -[ "void" { "fortran_test_record*" } ] -[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test -! fortran-sig>c-sig + [ "double" { } ] + [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "float" { "int*" "char*" "float*" "double*" "long" } ] -[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-float*" } ] + [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] -[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-double*" } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] -[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "int*" } ] + [ "integer(*)" fortran-ret-type>c-type ] unit-test -! fortran-record>c-struct + [ "void" { "fortran_test_record*" } ] + [ "fortran_test_record" fortran-ret-type>c-type ] unit-test -[ { - { "double" "ex" } - { "float" "wye" } - { "int" "zee" } - { "char[20]" "woo" } -} ] [ - { - { "DOUBLE-PRECISION" "EX" } - { "REAL" "WYE" } - { "INTEGER" "ZEE" } - { "CHARACTER(20)" "WOO" } - } fortran-record>c-struct -] unit-test + ! fortran-sig>c-sig -! RECORD: + [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] + unit-test -[ 16 ] [ "fortran_test_record" heap-size ] unit-test -[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test -[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test -[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + [ "char" { "char*" "char*" "int*" "long" } ] + [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -! (fortran-invoke) + [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -[ [ - ! [fortran-args>c-args] - { - [ { - [ ascii string>alien ] - [ ] - [ ] - [ ] - [ 1 0 ? ] - } spread ] - [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] - } 5 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "funtimes_" - { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } - alien-invoke - ] 6 nkeep - ! [fortran-results>] - shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) - { - [ drop ] - [ drop ] - [ drop ] - [ *float ] - [ drop ] - [ drop ] - } spread -] ] [ - f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } - (fortran-invoke) -] unit-test + [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -[ [ - ! [fortran-args>c-args] - { - [ { [ ] } spread ] - [ { [ drop ] } spread ] - } 1 ncleave - ! [fortran-invoke] - [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ] - 1 nkeep - ! [fortran-results>] - shuffle( reta aa -- reta aa ) - { [ ] [ drop ] } spread -] ] [ - "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } - (fortran-invoke) -] unit-test + ! fortran-record>c-struct -[ [ - ! [] - [ "complex-float" ] 1 ndip - ! [fortran-args>c-args] - { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "complex-float*" "float*" } - alien-invoke - ] 2 nkeep - ! [fortran-results>] - shuffle( reta aa -- reta aa ) - { [ *complex-float ] [ drop ] } spread -] ] [ - "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } - (fortran-invoke) -] unit-test + [ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } + } ] [ + { + { "DOUBLE-PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct + ] unit-test -[ [ - ! [] - [ 20 20 ] 0 ndip - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "char*" "long" } - alien-invoke - ] 2 nkeep - ! [fortran-results>] - shuffle( reta retb -- reta retb ) - { [ ] [ ascii alien>nstring ] } spread -] ] [ - "CHARACTER*20" "funpack" "FUN_TIMES" { } - (fortran-invoke) -] unit-test + ! RECORD: -[ [ - ! [] - [ 10 10 ] 3 ndip - ! [fortran-args>c-args] - { - [ { - [ ascii string>alien ] - [ ] - [ ascii string>alien ] - } spread ] - [ { [ length ] [ drop ] [ length ] } spread ] - } 3 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "char*" "long" "char*" "float*" "char*" "long" "long" } - alien-invoke - ] 7 nkeep - ! [fortran-results>] - shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) - { - [ ] - [ ascii alien>nstring ] - [ ] - [ ascii alien>nstring ] - [ *float ] - [ ] - [ ascii alien>nstring ] - } spread -] ] [ - "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } - (fortran-invoke) -] unit-test + [ 16 ] [ "fortran_test_record" heap-size ] unit-test + [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test + [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test + [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + ! (fortran-invoke) + + [ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "funtimes_" + { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) + { + [ drop ] + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + } spread + ] ] [ + f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + (fortran-invoke) + ] unit-test + + [ [ + ! [fortran-args>c-args] + { + [ { [ ] } spread ] + [ { [ drop ] } spread ] + } 1 ncleave + ! [fortran-invoke] + [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread + ] ] [ + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread + ] ] [ + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 20 20 ] 0 ndip + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread + ] ] [ + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 10 10 ] 3 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ascii string>alien ] + } spread ] + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" "char*" "float*" "char*" "long" "long" } + alien-invoke + ] 7 nkeep + ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) + { + [ ] + [ ascii alien>nstring ] + [ ] + [ ascii alien>nstring ] + [ *float ] + [ ] + [ ascii alien>nstring ] + } spread + ] ] [ + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) + ] unit-test + +] with-variable ! intel-unix-abi + +intel-windows-abi fortran-abi [ + + [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +f2c-abi fortran-abi [ + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "double" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +gfortran-abi fortran-abi [ + + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-double*" } ] + [ "double-complex(3)" fortran-ret-type>c-type ] unit-test + +] with-variable diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 9327c7b02c..cdf64ecb10 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,11 +5,10 @@ byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges -math.order sorting system ; +math.order sorting strings system ; IN: alien.fortran -! XXX this currently only supports the gfortran/f2c abi. -! XXX we should also support ifort at some point for commercial BLASes +SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; << : add-f2c-libraries ( -- ) @@ -22,18 +21,55 @@ os netbsd? [ add-f2c-libraries ] when : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; -: fortran-name>symbol-name ( fortran-name -- c-name ) - >lower CHAR: _ over member? - [ "__" append ] [ "_" append ] if ; - ERROR: invalid-fortran-type type ; DEFER: fortran-sig>c-sig DEFER: fortran-ret-type>c-type DEFER: fortran-arg-type>c-type +DEFER: fortran-name>symbol-name + +SYMBOL: library-fortran-abis +SYMBOL: fortran-abi +library-fortran-abis [ H{ } clone ] initialize lower "_" append ; +: lowercase-name-with-extra-underscore ( name -- name' ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +HOOK: fortran-c-abi fortran-abi ( -- abi ) +M: f2c-abi fortran-c-abi "cdecl" ; +M: gfortran-abi fortran-c-abi "cdecl" ; +M: intel-unix-abi fortran-c-abi "cdecl" ; +M: intel-windows-abi fortran-c-abi "cdecl" ; + +HOOK: real-functions-return-double? fortran-abi ( -- ? ) +M: f2c-abi real-functions-return-double? t ; +M: gfortran-abi real-functions-return-double? f ; +M: intel-unix-abi real-functions-return-double? f ; +M: intel-windows-abi real-functions-return-double? f ; + +HOOK: complex-functions-return-by-value? fortran-abi ( -- ? ) +M: f2c-abi complex-functions-return-by-value? f ; +M: gfortran-abi complex-functions-return-by-value? t ; +M: intel-unix-abi complex-functions-return-by-value? f ; +M: intel-windows-abi complex-functions-return-by-value? f ; + +HOOK: character(1)-maps-to-char? fortran-abi ( -- ? ) +M: f2c-abi character(1)-maps-to-char? f ; +M: gfortran-abi character(1)-maps-to-char? f ; +M: intel-unix-abi character(1)-maps-to-char? t ; +M: intel-windows-abi character(1)-maps-to-char? t ; + +HOOK: mangle-name fortran-abi ( name -- name' ) +M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; +M: gfortran-abi mangle-name lowercase-name-with-underscore ; +M: intel-unix-abi mangle-name lowercase-name-with-underscore ; +M: intel-windows-abi mangle-name >upper ; + TUPLE: fortran-type dims size out? ; TUPLE: number-type < fortran-type ; @@ -107,10 +143,14 @@ M: double-complex-type (fortran-type>c-type) M: misc-type (fortran-type>c-type) dup name>> simple-type ; +: single-char? ( character-type -- ? ) + { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ; + : fix-character-type ( character-type -- character-type' ) clone dup size>> [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] - [ dup dims>> [ ] [ { 1 } >>dims ] if ] if ; + [ dup dims>> [ ] [ f >>dims ] if ] if + dup single-char? [ f >>dims ] when ; M: character-type (fortran-type>c-type) fix-character-type "char" simple-type ; @@ -142,22 +182,23 @@ M: character-type (fortran-type>c-type) GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; -M: character-type added-c-args drop { "long" } ; +M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ; GENERIC: returns-by-value? ( type -- ? ) M: f returns-by-value? drop t ; M: fortran-type returns-by-value? drop f ; M: number-type returns-by-value? dims>> not ; -M: complex-type returns-by-value? drop f ; +M: character-type returns-by-value? fix-character-type single-char? ; +M: complex-type returns-by-value? + { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ; GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; -! XXX F2C claims to return double for REAL typed functions -! XXX OSX Accelerate.framework uses float -! M: real-type (fortran-ret-type>c-type) drop "double" ; +M: real-type (fortran-ret-type>c-type) + drop real-functions-return-double? [ "double" ] [ "float" ] if ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline @@ -209,7 +250,9 @@ M: double-complex-type (fortran-arg>c-args) [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) - drop [ ascii string>alien ] [ length ] ; + fix-character-type single-char? + [ [ first ] [ drop ] ] + [ [ ascii string>alien ] [ length ] ] if ; M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; @@ -255,7 +298,9 @@ M: double-complex-type (fortran-result>) [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop { [ ] [ ascii alien>nstring ] } ; + fix-character-type single-char? + [ { [ *char 1string ] } ] + [ { [ ] [ ascii alien>nstring ] } ] if ; M: misc-type (fortran-result>) drop { [ ] } ; @@ -331,8 +376,18 @@ M: character-type () append \ spread [ ] 2sequence append ; +: (add-fortran-library) ( fortran-abi name -- ) + library-fortran-abis get-global set-at ; + PRIVATE> +: add-fortran-library ( name soname fortran-abi -- ) + [ fortran-abi [ fortran-c-abi ] with-variable add-library ] + [ nip swap (add-fortran-library) ] 3bi ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + mangle-name ; + : fortran-type>c-type ( fortran-type -- c-type ) parse-fortran-type (fortran-type>c-type) ; @@ -344,7 +399,7 @@ PRIVATE> parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ "void" swap - [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) @@ -388,4 +443,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) [ "()" subseq? not ] filter define-fortran-function ; parsing : LIBRARY: - scan "c-library" set ; parsing + scan + [ "c-library" set ] + [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 77cee1aa82..1749103ce4 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -3,9 +3,11 @@ IN: math.blas.ffi << "blas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - [ "libblas.so" "cdecl" add-library ] + { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] } + { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] } + { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] } + { [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] } + [ "libblas.so" f2c-abi add-fortran-library ] } cond >> From 0279270dda37a45323bdb3170970ec62abab3005 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 15:11:39 -0600 Subject: [PATCH 156/170] un-unportable the blas stuff --- basis/alien/fortran/tags.txt | 1 - basis/math/blas/ffi/tags.txt | 1 - basis/math/blas/matrices/tags.txt | 1 - basis/math/blas/vectors/tags.txt | 1 - 4 files changed, 4 deletions(-) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 58465edeb5..2a9b5def7a 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,3 +1,2 @@ fortran ffi -unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index a4a4ea88ab..f468a9989d 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,4 +1,3 @@ math bindings fortran -unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable From 07caee3405a9ae8c2f9aa2125b74aac279d41131 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:16:12 -0600 Subject: [PATCH 157/170] Update some existing code to use initialize --- basis/cocoa/cocoa.factor | 2 +- basis/cocoa/messages/messages.factor | 8 ++++---- basis/compiler/utilities/utilities.factor | 2 +- basis/concurrency/messaging/messaging.factor | 2 +- basis/help/help.factor | 2 +- basis/help/topics/topics.factor | 4 ++-- basis/html/templates/chloe/syntax/syntax.factor | 2 +- basis/http/server/server.factor | 2 +- basis/io/encodings/iana/iana.factor | 4 ++-- basis/tools/annotations/annotations.factor | 2 +- basis/ui/cocoa/cocoa.factor | 6 +++--- basis/ui/gadgets/worlds/worlds.factor | 2 +- core/alien/alien.factor | 2 +- core/compiler/units/units.factor | 4 +--- core/io/backend/backend.factor | 2 +- core/parser/parser.factor | 2 +- core/strings/parser/parser.factor | 6 +++--- core/words/words.factor | 4 ++-- extra/mason/config/config.factor | 4 ++-- 19 files changed, 30 insertions(+), 32 deletions(-) diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 44252a3b19..01f134e283 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -29,7 +29,7 @@ SYMBOL: super-sent-messages SYMBOL: frameworks -frameworks global [ V{ } clone or ] change-at +frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 60bdde262c..529efeb564 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -19,8 +19,8 @@ IN: cocoa.messages SYMBOL: message-senders SYMBOL: super-message-senders -message-senders global [ H{ } assoc-like ] change-at -super-message-senders global [ H{ } assoc-like ] change-at +message-senders [ H{ } clone ] initialize +super-message-senders [ H{ } clone ] initialize : cache-stub ( method function hash -- ) [ @@ -53,7 +53,7 @@ MEMO: ( name -- sel ) f \ selector boa ; SYMBOL: objc-methods -objc-methods global [ H{ } assoc-like ] change-at +objc-methods [ H{ } clone ] initialize : lookup-method ( selector -- method ) dup objc-methods get at @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks global [ H{ } clone or ] change-at +class-init-hooks [ H{ } clone or ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ec4ced8c9f..31faaef480 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -24,4 +24,4 @@ IN: compiler.utilities SYMBOL: yield-hook -yield-hook global [ [ ] or ] change-at +yield-hook [ [ ] ] initialize diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 61a3c38991..ce7f7d6110 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -85,4 +85,4 @@ PRIVATE> : get-process ( name -- process ) dup registered-processes at [ ] [ thread ] ?if ; -\ registered-processes global [ H{ } assoc-like ] change-at +\ registered-processes [ H{ } clone ] initialize diff --git a/basis/help/help.factor b/basis/help/help.factor index 272bdc1db3..f980032a8b 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; SYMBOL: help-hook -help-hook global [ [ print-topic ] or ] change-at +help-hook [ [ print-topic ] ] initialize : help ( topic -- ) help-hook get call ; diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index e6b19d5baa..8c687eb1d5 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -27,11 +27,11 @@ M: link summary ! Help articles SYMBOL: articles -articles global [ H{ } assoc-like ] change-at +articles [ H{ } clone ] initialize SYMBOL: article-xref -article-xref global [ H{ } assoc-like ] change-at +article-xref [ H{ } clone ] initialize GENERIC: article-name ( topic -- string ) GENERIC: article-title ( topic -- string ) diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index f149c3fe47..faf8bed66b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -11,7 +11,7 @@ html.templates ; SYMBOL: tags -tags global [ H{ } clone or ] change-at +tags [ H{ } clone ] initialize : define-chloe-tag ( name quot -- ) swap tags get set-at ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index b6ee70057b..f2f3deead2 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -161,7 +161,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> or ] change-at +main-responder [ <404> ] initialize : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index a56bd1194b..6afae92429 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -47,8 +47,8 @@ PRIVATE> "resource:basis/io/encodings/iana/character-sets" utf8 make-aliases aliases set-global -n>e-table global [ initial-n>e or ] change-at -e>n-table global [ initial-e>n or ] change-at +n>e-table [ initial-n>e ] initialize +e>n-table [ initial-e>n ] initialize : register-encoding ( descriptor name -- ) [ diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index ecf3ba0a76..b436be5163 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -word-timing global [ H{ } clone or ] change-at +word-timing [ H{ } clone ] initialize : reset-word-timing ( -- ) word-timing get clear-assoc ; diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 331c0a698c..2fc8856b26 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -141,9 +141,9 @@ CLASS: { SYMBOL: cocoa-init-hook -cocoa-init-hook global [ - [ "MiniFactor.nib" load-nib install-app-delegate ] or -] change-at +cocoa-init-hook [ + [ "MiniFactor.nib" load-nib install-app-delegate ] +] initialize M: cocoa-ui-backend ui "UI" assert.app [ diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 732a438203..f57fb60bcd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -81,7 +81,7 @@ SYMBOL: ui-error-hook : ui-error ( error -- ) ui-error-hook get [ call ] [ die ] if* ; -ui-error-hook global [ [ rethrow ] or ] change-at +ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 93d1a8e306..52e9cd0f30 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -51,7 +51,7 @@ M: alien equal? SYMBOL: libraries -libraries global [ H{ } assoc-like ] change-at +libraries [ H{ } clone ] initialize TUPLE: library path abi dll ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 999b783c48..ac3e99e24c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -178,6 +178,4 @@ SYMBOL: remake-generics-hook : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; -recompile-hook global -[ [ default-recompile-hook ] or ] -change-at +recompile-hook [ [ default-recompile-hook ] ] initialize diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index fd5567cfa2..2f0bb1063f 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -8,7 +8,7 @@ SYMBOL: io-backend SINGLETON: c-io-backend -io-backend global [ c-io-backend or ] change-at +io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4be7cfa891..971ba245dd 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -200,7 +200,7 @@ SYMBOL: interactive-vocabs SYMBOL: print-use-hook -print-use-hook global [ [ ] or ] change-at +print-use-hook [ [ ] ] initialize : parse-fresh ( lines -- quot ) [ diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 4062e16e3d..8c9d0b5557 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -22,9 +22,9 @@ ERROR: bad-escape ; SYMBOL: name>char-hook -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at +name>char-hook [ + [ "Unicode support not available" throw ] +] initialize : unicode-escape ( str -- ch str' ) "{" ?head-slice [ diff --git a/core/words/words.factor b/core/words/words.factor index 3197d0a6f6..8648664031 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -96,11 +96,11 @@ M: word uses ( word -- seq ) SYMBOL: compiled-crossref -compiled-crossref global [ H{ } assoc-like ] change-at +compiled-crossref [ H{ } clone ] initialize SYMBOL: compiled-generic-crossref -compiled-generic-crossref global [ H{ } assoc-like ] change-at +compiled-generic-crossref [ H{ } clone ] initialize : (compiled-xref) ( word dependencies word-prop variable -- ) [ [ set-word-prop ] curry ] diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index b1739d85fa..51b09543f4 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -81,7 +81,7 @@ SYMBOL: upload-directory ! Optional: override ssh and scp command names SYMBOL: scp-command -scp-command global [ "scp" or ] change-at +scp-command [ "scp" ] initialize SYMBOL: ssh-command -ssh-command global [ "ssh" or ] change-at +ssh-command [ "ssh" ] initialize From a0421edf97056f14a1dceb9f0e90a553cbf28ca4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 16:39:24 -0600 Subject: [PATCH 158/170] set fortran abi in fortran-invoke macro --- basis/alien/fortran/fortran.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index cdf64ecb10..a2ffc55c02 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -418,8 +418,12 @@ PRIVATE> : RECORD: scan in get parse-definition define-fortran-record ; parsing +: set-fortran-abi ( library -- ) + library-fortran-abis get-global at fortran-abi set ; + : (fortran-invoke) ( return library function parameters -- quot ) { + [ 2drop nip set-fortran-abi ] [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] @@ -445,5 +449,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) : LIBRARY: scan [ "c-library" set ] - [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + [ set-fortran-abi ] bi ; parsing From 9060905983c9d11c7a26cce5a027278da2f08b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:52:27 -0600 Subject: [PATCH 159/170] Fix bootstrap --- basis/cocoa/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 529efeb564..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks [ H{ } clone or ] initialize +class-init-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ From 8bad9f014ac500647a3c10b06956a3956f86e187 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 16:59:55 -0600 Subject: [PATCH 160/170] case now throws the value it can't find --- core/combinators/combinators-tests.factor | 16 +++++++++++++++- core/combinators/combinators.factor | 4 ++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a73e22e31..beb50f1162 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -323,4 +323,18 @@ DEFER: corner-case-1 [ t ] [ \ corner-case-1 optimized>> ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test -[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test \ No newline at end of file +[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test + +: test-case-8 ( n -- ) + { + { 1 [ "foo" ] } + } case ; + +[ 3 test-case-8 ] +[ object>> 3 = ] must-fail-with + +[ + 3 { + { 1 [ "foo" ] } + } case +] [ object>> 3 = ] must-fail-with diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e356a6d246..daf247d678 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -49,7 +49,7 @@ ERROR: no-cond ; reverse [ no-cond ] swap alist>quot ; ! case -ERROR: no-case ; +ERROR: no-case object ; : case-find ( obj assoc -- obj' ) [ @@ -66,7 +66,7 @@ ERROR: no-case ; case-find { { [ dup array? ] [ nip second call ] } { [ dup callable? ] [ call ] } - { [ dup not ] [ no-case ] } + { [ dup not ] [ drop no-case ] } } cond ; : linear-case-quot ( default assoc -- quot ) From 970953be1f3dcd874f35c131c6b00adafa43e4cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:17:36 -0600 Subject: [PATCH 161/170] fix tiff/bitmaps color order --- extra/images/backend/backend.factor | 7 +++++-- extra/images/bitmap/bitmap.factor | 12 +++++++++++- extra/images/tiff/tiff.factor | 12 +++++++++++- extra/images/viewer/viewer.factor | 20 +++++++++++++------- 4 files changed, 40 insertions(+), 11 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index ef2a9a4248..5e05db0f4d 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -3,16 +3,19 @@ USING: accessors kernel ; IN: images.backend -TUPLE: image width height depth pitch buffer ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; + +TUPLE: image width height depth pitch component-order buffer ; GENERIC: load-image* ( path tuple -- image ) : load-image ( path class -- image ) new load-image* ; -: new-image ( width height depth buffer class -- image ) +: new-image ( width height depth component-order buffer class -- image ) new swap >>buffer + swap >>component-order swap >>depth swap >>height swap >>width ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 50975b2bb3..14d52fdaf8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,8 +97,18 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; +ERROR: unknown-component-order bitmap ; + +: bitmap>component-order ( bitmap -- object ) + bit-count>> { + { 32 [ BGRA ] } + { 24 [ BGR ] } + { 8 [ BGR ] } + [ unknown-component-order ] + } case ; + : bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 4be81af095..922e302040 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays +kernel pack endian constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping images.backend ; @@ -260,17 +260,27 @@ ERROR: bad-small-ifd-type n ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; +ERROR: unknown-component-order ifd ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag sum { + { 32 [ RGBA ] } + [ unknown-component-order ] + } case ; + : ifd>image ( ifd -- image ) { [ image-width find-tag ] [ image-length find-tag ] [ bits-per-sample find-tag sum ] + [ ifd-component-order ] [ buffer>> ] } cleave tiff-image new-image ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; + : load-tiff ( path -- parsed-tiff ) binary [ diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 4d5df4874a..0b01d75748 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -22,12 +22,18 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: bits>gl-params ( n -- gl-bgr gl-format ) +: gl-component-order ( singletons -- n ) { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + { BGR [ GL_BGR ] } + { RGB [ GL_BGR ] } + { BGRA [ GL_BGRA ] } + { RGBA [ GL_RGBA ] } + ! { RGBX [ GL_RGBX ] } + ! { BGRX [ GL_BGRX ] } + ! { ARGB [ GL_ARGB ] } + ! { ABGR [ GL_ABGR ] } + ! { XRGB [ GL_XRGB ] } + ! { XBGR [ GL_XBGR ] } } case ; M: bitmap-image draw-image ( bitmap -- ) @@ -44,7 +50,7 @@ M: bitmap-image draw-image ( bitmap -- ) ] [ width>> abs ] [ height>> abs ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; @@ -56,7 +62,7 @@ M: tiff-image draw-image ( tiff -- ) { [ height>> ] [ width>> ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; From 46bfb5c8eab23c26fd5b2b98c62db491b4253354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:20:36 -0600 Subject: [PATCH 162/170] clean up --- extra/images/images.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/images/images.factor b/extra/images/images.factor index eb4fc63fee..4b4673333f 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -6,8 +6,7 @@ io.pathnames ; IN: images : ( path -- image ) - normalize-path dup "." split1-last nip >lower - { + dup file-extension >lower { { "bmp" [ bitmap-image load-image ] } { "tiff" [ tiff-image load-image ] } } case ; From c2e6ef0366fde96c9cddc3141af42f5023cf80de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:23:21 -0600 Subject: [PATCH 163/170] remove dead pathname --- extra/images/bitmap/bitmap-tests.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index a2b3188749..a7deae3178 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -5,9 +5,6 @@ IN: images.bitmap.tests : test-bitmap24 ( -- path ) "resource:extra/images/test-images/thiswayup24.bmp" ; -: test-bitmap16 ( -- path ) - "resource:extra/images/test-images/rgb16bit.bmp" ; - : test-bitmap8 ( -- path ) "resource:extra/images/test-images/rgb8bit.bmp" ; From cf99c7afd1bdd8e9d1d173f594b5efff6f19eac7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:25:02 -0600 Subject: [PATCH 164/170] no locals in bit-arrays --- basis/bit-arrays/bit-arrays.factor | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f1ba71ce1e..3da22e09d6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel -kernel.private locals sequences sequences.private byte-arrays +kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry ; IN: bit-arrays @@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ \ } [ >bit-array ] parse-literal ; parsing -:: integer>bit-array ( n -- bit-array ) - n zero? [ 0 ] [ - [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | - [ n' zero? ] [ - n' out underlying>> i set-alien-unsigned-1 - n' -8 shift n'! - i 1+ i! - ] [ ] until - out - ] +: integer>bit-array ( n -- bit-array ) + dup 0 = [ + + ] [ + [ log2 1+ 0 ] keep + [ dup 0 = ] [ + [ pick underlying>> pick set-alien-unsigned-1 ] keep + [ 1+ ] [ -8 shift ] bi* + ] [ ] until 2drop ] if ; : bit-array>integer ( bit-array -- n ) From a1e521b54ee51f3a2e2a9329923e3d97b04551fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:42:21 -0600 Subject: [PATCH 165/170] working on images protocol --- extra/images/backend/backend.factor | 44 ++++++++++++++++----- extra/images/bitmap/bitmap.factor | 21 +++++----- extra/images/images.factor | 17 +++++++-- extra/images/tiff/tiff.factor | 24 ++++++------ extra/images/viewer/viewer.factor | 59 +++++------------------------ 5 files changed, 77 insertions(+), 88 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 5e05db0f4d..fb859f31a5 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,21 +1,47 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel ; +USING: accessors kernel grouping fry sequences combinators ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +! RGBA -TUPLE: image width height depth pitch component-order buffer ; +TUPLE: image dim component-order bitmap ; + +TUPLE: normalized-image < image ; GENERIC: load-image* ( path tuple -- image ) -: load-image ( path class -- image ) - new load-image* ; +GENERIC: >image ( object -- image ) -: new-image ( width height depth component-order buffer class -- image ) +: no-op ( -- ) ; + +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ no-op ] } + { BGRA [ + [ + [ 4 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip reverse-here ] each + [ 255 suffix ] map concat + ] change-bitmap + ] } + } case RGBA >>component-order ; + +: normalize-image ( image -- image ) + normalize-component-order ; + +: new-image ( dim component-order bitmap class -- image ) new - swap >>buffer + swap >>bitmap swap >>component-order - swap >>depth - swap >>height - swap >>width ; inline + swap >>dim ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 14d52fdaf8..7b59827d02 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ; TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? buffer ; : array-copy ( bitmap array -- bitmap array' ) @@ -87,12 +86,8 @@ M: bitmap-magic summary parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; -: alpha-channel-zero? ( bitmap -- ? ) - buffer>> 4 3 [ 0 = ] all? ; - : process-bitmap-data ( bitmap -- bitmap ) - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? ; + dup raw-bitmap>buffer >>buffer ; : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; @@ -107,13 +102,15 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave - bitmap-image new-image ; +M: bitmap >image ( bitmap -- bitmap-image ) + { + [ [ width>> ] [ height>> ] bi 2array ] + [ bitmap>component-order ] + [ buffer>> ] + } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) - drop load-bitmap - bitmap>image ; + drop load-bitmap >image ; MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ @@ -122,7 +119,7 @@ MACRO: (nbits>bitmap) ( bits -- ) swap >>height swap >>width swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count bitmap>image + _ >>bit-count >image ] ; : bgr>bitmap ( array height width -- bitmap ) diff --git a/extra/images/images.factor b/extra/images/images.factor index 4b4673333f..3df7b5d2d1 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -5,8 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend io.pathnames ; IN: images -: ( path -- image ) - dup file-extension >lower { - { "bmp" [ bitmap-image load-image ] } - { "tiff" [ tiff-image load-image ] } +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] } case ; + +: load-image ( path -- image ) + dup image-class new load-image* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 922e302040..dc40f648cc 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -13,7 +13,7 @@ TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next -processed-tags strips buffer ; +processed-tags strips bitmap ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; @@ -257,39 +257,37 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; +: strips>bitmap ( ifd -- ifd ) + dup strips>> concat >>bitmap ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag sum { { 32 [ RGBA ] } + { 24 [ RGB ] } [ unknown-component-order ] } case ; -: ifd>image ( ifd -- image ) +M: ifd >image ( ifd -- image ) { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum ] + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] - [ buffer>> ] + [ bitmap>> ] } cleave tiff-image new-image ; -: parsed-tiff>images ( tiff -- sequence ) - ifds>> [ ifd>image ] map ; - +M: parsed-tiff >image ( image -- image ) + ifds>> [ >image ] map first ; : load-tiff ( path -- parsed-tiff ) binary [ read-header dup endianness>> [ read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each ] with-endianness ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) - drop load-tiff parsed-tiff>images first ; + drop load-tiff >image ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 0b01d75748..f99c34f509 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators images.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render images.tiff sequences multiline -images.backend images io.pathnames strings ; +USING: accessors images images.backend io.pathnames kernel +namespaces opengl opengl.gl sequences strings ui ui.gadgets +ui.gadgets.panes ui.render ; IN: images.viewer TUPLE: image-gadget < gadget { image image } ; -GENERIC: draw-image ( image -- ) - M: image-gadget pref-dim* - image>> - [ width>> ] [ height>> ] bi - [ abs ] bi@ 2array ; + image>> dim>> ; + +: draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ] + [ bitmap>> ] bi glDrawPixels ; M: image-gadget draw-gadget* ( gadget -- ) origin get [ image>> draw-image ] with-translation ; @@ -22,50 +22,9 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: gl-component-order ( singletons -- n ) - { - { BGR [ GL_BGR ] } - { RGB [ GL_BGR ] } - { BGRA [ GL_BGRA ] } - { RGBA [ GL_RGBA ] } - ! { RGBX [ GL_RGBX ] } - ! { BGRX [ GL_BGRX ] } - ! { ARGB [ GL_ARGB ] } - ! { ABGR [ GL_ABGR ] } - ! { XRGB [ GL_XRGB ] } - ! { XBGR [ GL_XBGR ] } - } case ; - -M: bitmap-image draw-image ( bitmap -- ) - { - [ - height>> dup 0 < [ - drop - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 swap abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - ] - [ width>> abs ] - [ height>> abs ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -M: tiff-image draw-image ( tiff -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - { - [ height>> ] - [ width>> ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - GENERIC: image. ( image -- ) M: string image. ( image -- ) gadget. ; From 1d5f6901c1224a8f964c148a5615739c87193297 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:48:10 -0600 Subject: [PATCH 166/170] fix bitmap drawing --- extra/images/backend/backend.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index fb859f31a5..796e9a3a66 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel grouping fry sequences combinators ; +USING: accessors kernel grouping fry sequences combinators +images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; @@ -37,8 +38,17 @@ GENERIC: >image ( object -- image ) ] } } case RGBA >>component-order ; +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; +M: bitmap-image normalize-scan-line-order + dup + [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat + >>bitmap ; + : normalize-image ( image -- image ) - normalize-component-order ; + normalize-component-order + normalize-scan-line-order ; : new-image ( dim component-order bitmap class -- image ) new From 7d60fcc5989134f95a57299615e94be2fbdfabd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:52:28 -0600 Subject: [PATCH 167/170] clean up some image code --- extra/images/backend/backend.factor | 7 +++---- extra/images/viewer/viewer.factor | 11 +++++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 796e9a3a66..2e626b73e6 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -5,7 +5,6 @@ images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -! RGBA TUPLE: image dim component-order bitmap ; @@ -42,9 +41,9 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; M: bitmap-image normalize-scan-line-order - dup - [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat - >>bitmap ; + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; : normalize-image ( image -- image ) normalize-component-order diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index f99c34f509..92277dfdef 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,10 +25,13 @@ M: image-gadget draw-gadget* ( gadget -- ) : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -GENERIC: image. ( image -- ) +GENERIC: image. ( object -- ) -M: string image. ( image -- ) gadget. ; +: default-image. ( path -- ) + gadget. ; -M: pathname image. ( image -- ) gadget. ; +M: string image. ( image -- ) default-image. ; -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) default-image. ; + +M: image image. ( image -- ) default-image. ; From 94f6d28f34d7a3f0a31a9c3c35ba354d54e69704 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 19:34:02 -0600 Subject: [PATCH 168/170] fix a method --- extra/images/backend/backend.factor | 5 ----- extra/images/bitmap/bitmap.factor | 5 +++++ 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 2e626b73e6..6d73a253ae 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -40,11 +40,6 @@ GENERIC: >image ( object -- image ) GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; -M: bitmap-image normalize-scan-line-order - dup dim>> '[ - _ first 4 * reverse concat - ] change-bitmap ; - : normalize-image ( image -- image ) normalize-component-order normalize-scan-line-order ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 7b59827d02..46f90e33f8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -112,6 +112,11 @@ M: bitmap >image ( bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap >image ; +M: bitmap-image normalize-scan-line-order + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; + MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ bitmap new From 5dd4bbcf42dab7018c3840f53feaefe923d2bd1b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 19:58:53 -0600 Subject: [PATCH 169/170] Defuse RTLD_GLOBAL time bomb in os-unix.c --- vm/os-unix.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index b49f7637af..97c29d8c6e 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -36,7 +36,7 @@ void init_ffi(void) void ffi_dlopen(F_DLL *dll) { - dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL); + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) From 610c43a3c3c6abf312ca15aa7aef30f187bf0549 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 20:49:10 -0600 Subject: [PATCH 170/170] remove circular using --- extra/images/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 6d73a253ae..756b98efee 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel grouping fry sequences combinators -images.bitmap math ; +math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;