From: Slava Pestov Date: Sun, 6 Jan 2008 17:30:23 +0000 (-0400) Subject: Fix conflict X-Git-Tag: 0.94~2763^2~165 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=8285eeda9a01b762673dfe038738506fe934d441 Fix conflict --- 8285eeda9a01b762673dfe038738506fe934d441 diff --cc core/classes/classes-docs.factor index 6cc08e9f8f,147714692d..859b6a95d5 mode 100755,100644..100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor diff --cc extra/assoc-heaps/assoc-heaps.factor index 0000000000,0c44950923..a5471c213f mode 000000,100644..100755 --- a/extra/assoc-heaps/assoc-heaps.factor +++ b/extra/assoc-heaps/assoc-heaps.factor @@@ -1,0 -1,48 +1,48 @@@ + USING: assocs heaps kernel sequences ; + IN: assoc-heaps + + TUPLE: assoc-heap assoc heap ; + + INSTANCE: assoc-heap assoc + INSTANCE: assoc-heap priority-queue + + C: assoc-heap + + : ( assoc -- obj ) ; + : ( assoc -- obj ) ; + + M: assoc-heap at* ( key assoc-heap -- value ? ) + assoc-heap-assoc at* ; + + M: assoc-heap assoc-size ( assoc-heap -- n ) + assoc-heap-assoc assoc-size ; + + TUPLE: assoc-heap-key-exists ; + + : check-key-exists ( key assoc-heap -- ) + assoc-heap-assoc key? + [ \ assoc-heap-key-exists construct-empty throw ] when ; + + M: assoc-heap set-at ( value key assoc-heap -- ) + [ check-key-exists ] 2keep + [ assoc-heap-assoc set-at ] 3keep + assoc-heap-heap swapd heap-push ; + + M: assoc-heap heap-empty? ( assoc-heap -- ? ) + assoc-heap-assoc assoc-empty? ; + + M: assoc-heap heap-length ( assoc-heap -- n ) - assoc-heap-assoc assoc-size ; ++ assoc-heap-assoc assoc-size ; + + M: assoc-heap heap-peek ( assoc-heap -- value key ) + assoc-heap-heap heap-peek ; + + M: assoc-heap heap-push ( value key assoc-heap -- ) + set-at ; + + M: assoc-heap heap-push-all ( assoc assoc-heap -- ) + swap [ rot set-at ] curry* each ; + + M: assoc-heap heap-pop ( assoc-heap -- value key ) + dup assoc-heap-heap heap-pop swap + rot dupd assoc-heap-assoc delete-at ; diff --cc extra/fjsc/fjsc.factor index 22031afb25,e469b61617..fdeed339d8 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@@ -1,8 -1,8 +1,8 @@@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. - USING: kernel lazy-lists parser-combinators parser-combinators.simple - strings promises sequences math math.parser namespaces words - quotations arrays hashtables io io.streams.string assocs ; -USING: kernel peg strings promises sequences math math.parser - namespaces words quotations arrays hashtables io ++USING: kernel peg strings promises sequences math math.parser ++ namespaces words quotations arrays hashtables io + io.streams.string assocs memoize ; IN: fjsc TUPLE: ast-number value ; @@@ -65,99 -53,137 +53,137 @@@ MEMO: 'identifier-ends' ( -- parser [ letter? not ] keep identifier-middle? not and and and and and - ] satisfy ; + ] satisfy repeat0 ; - LAZY: 'identifier-middle' ( -- parser ) - [ identifier-middle? ] satisfy ; + MEMO: 'identifier-middle' ( -- parser ) + [ identifier-middle? ] satisfy repeat1 ; - LAZY: 'identifier' ( -- parser ) - 'identifier-ends' - 'identifier-middle' <&> - 'identifier-ends' <:&> - [ concat >string f ] <@ ; + MEMO: 'identifier' ( -- parser ) + [ + 'identifier-ends' , + 'identifier-middle' , + 'identifier-ends' , - ] { } make seq [ - concat >string f ++ ] { } make seq [ ++ concat >string f + ] action ; DEFER: 'expression' - LAZY: 'effect-name' ( -- parser ) + MEMO: 'effect-name' ( -- parser ) [ [ blank? not ] keep + [ CHAR: ) = not ] keep CHAR: - = not - and - ] satisfy [ >string ] <@ ; - - LAZY: 'stack-effect' ( -- parser ) - "(" token sp - 'effect-name' sp <*> &> - "--" token sp <& - 'effect-name' sp <*> <&> - ")" token sp <& [ first2 ] <@ ; - - LAZY: 'define' ( -- parser ) - ":" token sp - 'identifier' sp [ ast-identifier-value ] <@ &> - 'stack-effect' sp <&> - 'expression' <:&> - ";" token sp <& [ first3 ] <@ ; - - LAZY: 'quotation' ( -- parser ) - "[" token sp - 'expression' [ ast-expression-values ] <@ &> - "]" token sp <& [ ] <@ ; - - LAZY: 'array' ( -- parser ) - "{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; - - LAZY: 'word' ( -- parser ) - "\\" token sp - 'identifier' sp &> [ ast-identifier-value f ] <@ ; - - LAZY: 'atom' ( -- parser ) - 'identifier' 'integer' [ ] <@ <|> 'string' [ ] <@ <|> ; - - LAZY: 'comment' ( -- parser ) - "#!" token sp - "!" token sp <|> [ - dup CHAR: \n = swap CHAR: \r = or not - ] satisfy <*> <&> [ drop ] <@ ; - - LAZY: 'USE:' ( -- parser ) - "USE:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; - - LAZY: 'IN:' ( -- parser ) - "IN:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; - - LAZY: 'USING:' ( -- parser ) - "USING:" token sp - 'identifier' sp [ ast-identifier-value ] <@ <+> &> - ";" token sp <& [ ] <@ ; - - LAZY: 'hashtable' ( -- parser ) - "H{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; - - LAZY: 'parsing-word' ( -- parser ) - 'USE:' - 'USING:' <|> - 'IN:' <|> ; - - LAZY: 'expression' ( -- parser ) - 'comment' - 'parsing-word' sp <|> - 'quotation' sp <|> - 'define' sp <|> - 'array' sp <|> - 'hashtable' sp <|> - 'word' sp <|> - 'atom' sp <|> - <*> [ ] <@ ; - - LAZY: 'statement' ( -- parser ) + and and + ] satisfy repeat1 [ >string ] action ; + + MEMO: 'stack-effect' ( -- parser ) + [ + "(" token hide , + 'effect-name' sp repeat0 , + "--" token sp hide , + 'effect-name' sp repeat0 , + ")" token sp hide , - ] { } make seq [ - first2 ++ ] { } make seq [ ++ first2 + ] action ; + + MEMO: 'define' ( -- parser ) + [ + ":" token sp hide , - 'identifier' sp [ ast-identifier-value ] action , ++ 'identifier' sp [ ast-identifier-value ] action , + 'stack-effect' sp optional , + 'expression' , + ";" token sp hide , + ] { } make seq [ first3 ] action ; + + MEMO: 'quotation' ( -- parser ) + [ + "[" token sp hide , - 'expression' [ ast-expression-values ] action , ++ 'expression' [ ast-expression-values ] action , + "]" token sp hide , + ] { } make seq [ first ] action ; + + MEMO: 'array' ( -- parser ) + [ + "{" token sp hide , + 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; + + MEMO: 'word' ( -- parser ) + [ + "\\" token sp hide , - 'identifier' sp , ++ 'identifier' sp , + ] { } make seq [ first ast-identifier-value f ] action ; + + MEMO: 'atom' ( -- parser ) + [ - 'identifier' , ++ 'identifier' , + 'integer' [ ] action , + 'string' [ ] action , + ] { } make choice ; + + MEMO: 'comment' ( -- parser ) + [ + [ + "#!" token sp , - "!" token sp , ++ "!" token sp , + ] { } make choice hide , + [ + dup CHAR: \n = swap CHAR: \r = or not + ] satisfy repeat0 , + ] { } make seq [ drop ] action ; + + MEMO: 'USE:' ( -- parser ) + [ + "USE:" token sp hide , - 'identifier' sp , ++ 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; + + MEMO: 'IN:' ( -- parser ) + [ + "IN:" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; + + MEMO: 'USING:' ( -- parser ) + [ + "USING:" token sp hide , + 'identifier' sp [ ast-identifier-value ] action repeat1 , + ";" token sp hide , + ] { } make seq [ first ] action ; + + MEMO: 'hashtable' ( -- parser ) + [ + "H{" token sp hide , - 'expression' [ ast-expression-values ] action , ++ 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; + + MEMO: 'parsing-word' ( -- parser ) + [ + 'USE:' , + 'USING:' , + 'IN:' , + ] { } make choice ; + + MEMO: 'expression' ( -- parser ) - [ ++ [ + [ + 'comment' , + 'parsing-word' sp , + 'quotation' sp , + 'define' sp , + 'array' sp , + 'hashtable' sp , + 'word' sp , + 'atom' sp , - ] { } make choice repeat0 [ ] action ++ ] { } make choice repeat0 [ ] action + ] delay ; + + MEMO: 'statement' ( -- parser ) 'expression' ; GENERIC: (compile) ( ast -- ) diff --cc extra/hello-world/deploy.factor index 06bad872be,06bad872be..6dee7d4be3 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@@ -1,13 -1,13 +1,13 @@@ USING: tools.deploy.config ; H{ ++ { deploy-c-types? f } ++ { deploy-ui? f } ++ { deploy-reflection 1 } { deploy-math? f } -- { deploy-word-defs? f } { deploy-word-props? f } ++ { deploy-word-defs? f } { deploy-name "Hello world (console)" } { "stop-after-last-window?" t } -- { deploy-c-types? f } { deploy-compiler? f } { deploy-io 2 } -- { deploy-ui? f } -- { deploy-reflection 1 } } diff --cc extra/http/http.factor index f6ea3d699f,6ecb3c5a71..9e5d34fa36 mode 100644,100644..100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@@ -60,11 -60,18 +60,18 @@@ IN: htt : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make ; - : build-url ( path query-params -- str ) + : hash>query ( hash -- str ) + [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map + "&" join ; + + : build-url ( str query-params -- newstr ) [ - swap % dup assoc-empty? [ - "?" % dup - [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map - "&" join % - ] unless drop + over % + dup assoc-empty? [ + 2drop + ] [ + CHAR: ? rot member? "&" "?" ? % + hash>query % + ] if ] "" make ; - ++ diff --cc extra/peg/search/search-docs.factor index 0000000000,d6dc5e543b..244dc7f838 mode 000000,100644..100755 --- a/extra/peg/search/search-docs.factor +++ b/extra/peg/search/search-docs.factor @@@ -1,0 -1,43 +1,43 @@@ + ! Copyright (C) 2006 Chris Double. + ! See http://factorcode.org/license.txt for BSD license. + USING: help.syntax help.markup peg peg.search ; + + HELP: tree-write -{ $values ++{ $values + { "object" "an object" } } -{ $description ++{ $description + "Write the object to the standard output stream, unless " + "it is an array, in which case recurse through the array " + "writing each object to the stream." } + { $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; + + HELP: search -{ $values - { "string" "a string" } - { "parser" "a peg based parser" } - { "seq" "a sequence" } ++{ $values ++ { "string" "a string" } ++ { "parser" "a peg based parser" } ++ { "seq" "a sequence" } + } -{ $description ++{ $description + "Returns a sequence containing the parse results of all substrings " + "from the input string that successfully parse using the " + "parser." + } - ++ + { $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" } + { $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" } + { $see-also replace } ; - ++ + HELP: replace -{ $values - { "string" "a string" } - { "parser" "a peg based parser" } - { "result" "a string" } ++{ $values ++ { "string" "a string" } ++ { "parser" "a peg based parser" } ++ { "result" "a string" } + } -{ $description ++{ $description + "Returns a copy of the original string but with all substrings that " + "successfully parse with the given parser replaced with " + "the result of that parser." -} ++} + { $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" } + { $see-also search } ; + diff --cc extra/peg/search/search-tests.factor index 0000000000,53dcbd99f5..b33161dfff mode 000000,100644..100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@@ -1,0 -1,18 +1,18 @@@ + ! Copyright (C) 2007 Chris Double. + ! See http://factorcode.org/license.txt for BSD license. + ! + USING: kernel math math.parser arrays tools.test peg peg.search ; + IN: temporary + + { V{ 123 456 } } [ - "abc 123 def 456" 'integer' search ++ "abc 123 def 456" 'integer' search + ] unit-test + + { V{ 123 "hello" 456 } } [ - "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search ++ "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search + ] unit-test + + { "abc 246 def 912" } [ - "abc 123 def 456" 'integer' [ 2 * number>string ] action replace ++ "abc 123 def 456" 'integer' [ 2 * number>string ] action replace + ] unit-test + diff --cc extra/peg/search/search.factor index 0000000000,86b6e114cf..6b34c03857 mode 000000,100755..100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@@ -1,0 -1,32 +1,32 @@@ + ! Copyright (C) 2006 Chris Double. + ! See http://factorcode.org/license.txt for BSD license. + USING: kernel math io io.streams.string sequences strings + combinators peg memoize arrays ; -IN: peg.search ++IN: peg.search + + : tree-write ( object -- ) - { ++ { + { [ dup number? ] [ write1 ] } + { [ dup string? ] [ write ] } + { [ dup sequence? ] [ [ tree-write ] each ] } + { [ t ] [ write ] } + } cond ; + + MEMO: any-char-parser ( -- parser ) + [ drop t ] satisfy ; + + : search ( string parser -- seq ) + any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast [ ] subset ++ parse-result-ast [ ] subset + ] [ + drop { } + ] if ; + + + : (replace) ( string parser -- seq ) + any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ; + + : replace ( string parser -- result ) + [ (replace) [ tree-write ] each ] string-out ; + + diff --cc extra/sequences/lib/lib.factor index a28fe32818,ba2fb055e2..269c22e811 mode 100755,100644..100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@@ -105,11 -106,19 +106,28 @@@ PRIVATE : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ nths ] curry map ; +: push-either ( elt quot accum1 accum2 -- ) + >r >r keep swap r> r> ? push ; inline + +: 2pusher ( quot -- quot accum1 accum2 ) + V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline + +: partition ( seq quot -- trueseq falseseq ) + over >r 2pusher >r >r each r> r> r> drop ; inline ++ + : cut-find ( seq pred -- before after ) + dupd find drop dup [ cut ] when ; + + : cut3 ( seq pred -- first mid last ) + [ cut-find ] keep [ not ] compose cut-find ; + + : (cut-all) ( seq pred quot -- ) + [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep + pick [ (cut-all) ] [ 3drop ] if ; + + : cut-all ( seq pred quot -- first mid last ) + [ (cut-all) ] { } make ; + + : human-sort ( seq -- newseq ) + [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc + sort-values keys ; diff --cc extra/tools/deploy/windows/windows.factor index 89dc0d8cc3,34580cf6f9..59e446af34 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@@ -33,13 -33,11 +33,12 @@@ TUPLE: windows-deploy-implementation T{ windows-deploy-implementation } deploy-implementation set-global -M: windows-deploy-implementation deploy +M: windows-deploy-implementation deploy* + stage1 "." resource-path cd dup deploy-config [ - [ deploy-name get create-exe-dir ] keep - [ deploy-name get image-name ] keep - namespace - deploy-name get open-in-explorer - ] bind deploy* ; + [ + [ deploy-name get create-exe-dir ] keep + [ deploy-name get image-name ] keep - deploy-name get + ] bind + ] keep stage2 open-in-explorer ; diff --cc extra/xml/utilities/utilities.factor index e64b9591a5,a86b1c9214..798b7f571a mode 100755,100644..100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@@ -1,140 -1,166 +1,165 @@@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences words io assocs -quotations strings parser arrays xml.data xml.writer debugger -splitting vectors ; -IN: xml.utilities - -! * System for words specialized on tag names - -TUPLE: process-missing process tag ; -M: process-missing error. - "Tag <" write - dup process-missing-tag print-name - "> not implemented on process process " write - process-missing-process word-name print ; - -: run-process ( tag word -- ) - 2dup "xtable" word-prop - >r dup name-tag r> at* [ 2nip call ] [ - drop \ process-missing construct-boa throw - ] if ; - -: PROCESS: - CREATE - dup H{ } clone "xtable" set-word-prop - dup [ run-process ] curry define-compound ; parsing - -: TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; - parsing - - -! * Common utility functions - -: build-tag* ( items name -- tag ) - assure-name swap >r f r> ; - -: build-tag ( item name -- tag ) - >r 1array r> build-tag* ; - -: standard-prolog ( -- prolog ) - T{ prolog f "1.0" "iso-8859-1" f } ; - -: build-xml ( tag -- xml ) - standard-prolog { } rot { } ; - -: children>string ( tag -- string ) - tag-children - dup [ string? ] all? - [ "XML tag unexpectedly contains non-text children" throw ] unless - concat ; - -: children-tags ( tag -- sequence ) - tag-children [ tag? ] subset ; - -: first-child-tag ( tag -- tag ) - tag-children [ tag? ] find nip ; - -! * Utilities for searching through XML documents -! These all work from the outside in, top to bottom. - -: with-delegate ( object quot -- object ) - over clone >r >r delegate r> call r> - [ set-delegate ] keep ; inline - -GENERIC# xml-each 1 ( quot tag -- ) inline -M: tag xml-each - [ call ] 2keep - swap tag-children [ swap xml-each ] curry* each ; -M: object xml-each - call ; -M: xml xml-each - >r delegate r> xml-each ; - -GENERIC# xml-map 1 ( quot tag -- tag ) inline -M: tag xml-map - swap clone over >r swap call r> - swap [ tag-children [ swap xml-map ] curry* map ] keep - [ set-tag-children ] keep ; -M: object xml-map - call ; -M: xml xml-map - swap [ swap xml-map ] with-delegate ; - -: xml-subset ( quot tag -- seq ) ! quot: tag -- ? - V{ } clone rot [ - swap >r [ swap call ] 2keep rot r> - swap [ [ push ] keep ] [ nip ] if - ] xml-each nip ; - -GENERIC# xml-find 1 ( quot tag -- tag ) inline -M: tag xml-find - [ call ] 2keep swap rot [ - f swap - [ nip over >r swap xml-find r> swap dup ] find - 2drop ! leaves result of quot - ] unless nip ; -M: object xml-find - keep f ? ; -M: xml xml-find - >r delegate r> xml-find ; - -GENERIC# xml-inject 1 ( quot tag -- ) inline -M: tag xml-inject - swap [ - swap [ call ] keep - [ xml-inject ] keep - ] change-each ; -M: object xml-inject 2drop ; -M: xml xml-inject >r delegate >r xml-inject ; - -! * Accessing part of an XML document -! for tag- words, a start means that it searches all children -! and no star searches only direct children - -: tag-named? ( name elem -- ? ) - dup tag? [ names-match? ] [ 2drop f ] if ; - -: tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd tag-named? ] xml-find nip ; - -: tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd tag-named? ] xml-subset nip ; - -: tag-named ( tag name/string -- matching-tag ) - ! like get-name-tag but only looks at direct children, - ! not all the children down the tree. - assure-name swap [ tag-named? ] curry* find nip ; - -: tags-named ( tag name/string -- tags-seq ) - assure-name swap [ tag-named? ] curry* subset ; - -: assert-tag ( name name -- ) - names-match? [ "Unexpected XML tag found" throw ] unless ; - -: insert-children ( children tag -- ) - dup tag-children [ push-all ] - [ >r V{ } like r> set-tag-children ] if ; - -: insert-child ( child tag -- ) - >r 1vector r> insert-children ; - -: tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ drop f ] if ; - -: tag-with-attr ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry find nip ; - -: tags-with-attr ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry subset ; - -: tag-with-attr* ( tag attr-value attr-name -- matching-tag ) - assure-name [ tag-with-attr? ] 2curry xml-find nip ; - -: tags-with-attr* ( tag attr-value attr-name -- tags-seq ) - assure-name [ tag-with-attr? ] 2curry xml-subset ; - -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - "id" tag-with-attr ; - -: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags ) - >r >r tags-named* r> r> tags-with-attr ; - +! Copyright (C) 2005, 2006 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences words io assocs +quotations strings parser arrays xml.data xml.writer debugger - splitting ; ++splitting vectors ; +IN: xml.utilities + +! * System for words specialized on tag names + +TUPLE: process-missing process tag ; +M: process-missing error. + "Tag <" write + dup process-missing-tag print-name + "> not implemented on process process " write + process-missing-process word-name print ; + +: run-process ( tag word -- ) + 2dup "xtable" word-prop + >r dup name-tag r> at* [ 2nip call ] [ + drop \ process-missing construct-boa throw + ] if ; + +: PROCESS: + CREATE + dup H{ } clone "xtable" set-word-prop + dup [ run-process ] curry define-compound ; parsing + +: TAG: + scan scan-word + parse-definition + swap "xtable" word-prop + rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; + parsing + + +! * Common utility functions + +: build-tag* ( items name -- tag ) - "" swap "" - swap >r { } r> ; ++ assure-name swap >r f r> ; + +: build-tag ( item name -- tag ) + >r 1array r> build-tag* ; + ++: standard-prolog ( -- prolog ) ++ T{ prolog f "1.0" "iso-8859-1" f } ; ++ +: build-xml ( tag -- xml ) - T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; ++ standard-prolog { } rot { } ; + +: children>string ( tag -- string ) + tag-children + dup [ string? ] all? + [ "XML tag unexpectedly contains non-text children" throw ] unless + concat ; + +: children-tags ( tag -- sequence ) + tag-children [ tag? ] subset ; + +: first-child-tag ( tag -- tag ) + tag-children [ tag? ] find nip ; + +! * Utilities for searching through XML documents +! These all work from the outside in, top to bottom. + +: with-delegate ( object quot -- object ) + over clone >r >r delegate r> call r> + [ set-delegate ] keep ; inline + +GENERIC# xml-each 1 ( quot tag -- ) inline +M: tag xml-each + [ call ] 2keep + swap tag-children [ swap xml-each ] curry* each ; +M: object xml-each + call ; +M: xml xml-each + >r delegate r> xml-each ; + +GENERIC# xml-map 1 ( quot tag -- tag ) inline +M: tag xml-map + swap clone over >r swap call r> + swap [ tag-children [ swap xml-map ] curry* map ] keep + [ set-tag-children ] keep ; +M: object xml-map + call ; +M: xml xml-map + swap [ swap xml-map ] with-delegate ; + +: xml-subset ( quot tag -- seq ) ! quot: tag -- ? + V{ } clone rot [ + swap >r [ swap call ] 2keep rot r> + swap [ [ push ] keep ] [ nip ] if + ] xml-each nip ; + +GENERIC# xml-find 1 ( quot tag -- tag ) inline +M: tag xml-find - [ call ] 2keep spin [ ++ [ call ] 2keep swap rot [ + f swap + [ nip over >r swap xml-find r> swap dup ] find + 2drop ! leaves result of quot + ] unless nip ; +M: object xml-find + keep f ? ; +M: xml xml-find + >r delegate r> xml-find ; + +GENERIC# xml-inject 1 ( quot tag -- ) inline +M: tag xml-inject + swap [ + swap [ call ] keep + [ xml-inject ] keep + ] change-each ; +M: object xml-inject 2drop ; +M: xml xml-inject >r delegate >r xml-inject ; + +! * Accessing part of an XML document ++! for tag- words, a start means that it searches all children ++! and no star searches only direct children + - : get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - swap [ - dup tag? - [ "id" swap at over = ] - [ drop f ] if - ] xml-find nip ; - - : (get-tag) ( name elem -- ? ) ++: tag-named? ( name elem -- ? ) + dup tag? [ names-match? ] [ 2drop f ] if ; + +: tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd (get-tag) ] xml-find nip ; ++ assure-name swap [ dupd tag-named? ] xml-find nip ; + +: tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd (get-tag) ] xml-subset nip ; ++ assure-name swap [ dupd tag-named? ] xml-subset nip ; + +: tag-named ( tag name/string -- matching-tag ) + ! like get-name-tag but only looks at direct children, + ! not all the children down the tree. - assure-name swap [ (get-tag) ] curry* find nip ; ++ assure-name swap [ tag-named? ] curry* find nip ; + +: tags-named ( tag name/string -- tags-seq ) - assure-name swap [ (get-tag) ] curry* subset ; ++ assure-name swap [ tag-named? ] curry* subset ; + +: assert-tag ( name name -- ) + names-match? [ "Unexpected XML tag found" throw ] unless ; ++ ++: insert-children ( children tag -- ) ++ dup tag-children [ push-all ] ++ [ >r V{ } like r> set-tag-children ] if ; ++ ++: insert-child ( child tag -- ) ++ >r 1vector r> insert-children ; ++ ++: tag-with-attr? ( elem attr-value attr-name -- ? ) ++ rot dup tag? [ at = ] [ drop f ] if ; ++ ++: tag-with-attr ( tag attr-value attr-name -- matching-tag ) ++ assure-name [ tag-with-attr? ] 2curry find nip ; ++ ++: tags-with-attr ( tag attr-value attr-name -- tags-seq ) ++ assure-name [ tag-with-attr? ] 2curry subset ; ++ ++: tag-with-attr* ( tag attr-value attr-name -- matching-tag ) ++ assure-name [ tag-with-attr? ] 2curry xml-find nip ; ++ ++: tags-with-attr* ( tag attr-value attr-name -- tags-seq ) ++ assure-name [ tag-with-attr? ] 2curry xml-subset ; ++ ++: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) ++ "id" tag-with-attr ; ++ ++: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags ) ++ >r >r tags-named* r> r> tags-with-attr ; diff --cc misc/factor.sh index 11ea2a9cdf,4913a57b75..b2cbb836e6 --- a/misc/factor.sh +++ b/misc/factor.sh @@@ -162,10 -163,12 +163,12 @@@ set_build_info() echo "OS, ARCH, or WORD is empty. Please report this" exit 5 fi -- ++ MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD BOOT_IMAGE=boot.$ARCH.$WORD.image if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH MAKE_TARGET=$OS-$ARCH BOOT_IMAGE=boot.macosx-ppc.image fi @@@ -266,7 -274,14 +274,14 @@@ update_bootstrap() } refresh_image() { - ./$FACTOR_BINARY -e="refresh-all save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + check_ret factor + } + + make_boot_image() { + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor - ++ } install_libraries() {