--- /dev/null
- assoc-heap-assoc assoc-size ;
+ 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-heap
+
+ : <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
+ : <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
+
+ 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 ;
+
+ 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 ;
! 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 ;
[ 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 <ast-identifier> ] <@ ;
+ MEMO: 'identifier' ( -- parser )
+ [
+ 'identifier-ends' ,
+ 'identifier-middle' ,
+ 'identifier-ends' ,
- ] { } make seq [
- concat >string f <ast-identifier>
++ ] { } make seq [
++ concat >string f <ast-identifier>
+ ] 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 <ast-stack-effect> ] <@ ;
-
- LAZY: 'define' ( -- parser )
- ":" token sp
- 'identifier' sp [ ast-identifier-value ] <@ &>
- 'stack-effect' sp <!?> <&>
- 'expression' <:&>
- ";" token sp <& [ first3 <ast-define> ] <@ ;
-
- LAZY: 'quotation' ( -- parser )
- "[" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "]" token sp <& [ <ast-quotation> ] <@ ;
-
- LAZY: 'array' ( -- parser )
- "{" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "}" token sp <& [ <ast-array> ] <@ ;
-
- LAZY: 'word' ( -- parser )
- "\\" token sp
- 'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
-
- LAZY: 'atom' ( -- parser )
- 'identifier' 'integer' [ <ast-number> ] <@ <|> 'string' [ <ast-string> ] <@ <|> ;
-
- LAZY: 'comment' ( -- parser )
- "#!" token sp
- "!" token sp <|> [
- dup CHAR: \n = swap CHAR: \r = or not
- ] satisfy <*> <&> [ drop <ast-comment> ] <@ ;
-
- LAZY: 'USE:' ( -- parser )
- "USE:" token sp
- 'identifier' sp &> [ ast-identifier-value <ast-use> ] <@ ;
-
- LAZY: 'IN:' ( -- parser )
- "IN:" token sp
- 'identifier' sp &> [ ast-identifier-value <ast-in> ] <@ ;
-
- LAZY: 'USING:' ( -- parser )
- "USING:" token sp
- 'identifier' sp [ ast-identifier-value ] <@ <+> &>
- ";" token sp <& [ <ast-using> ] <@ ;
-
- LAZY: 'hashtable' ( -- parser )
- "H{" token sp
- 'expression' [ ast-expression-values ] <@ &>
- "}" token sp <& [ <ast-hashtable> ] <@ ;
-
- 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 <|>
- <*> [ <ast-expression> ] <@ ;
-
- 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 <ast-stack-effect>
++ ] { } make seq [
++ first2 <ast-stack-effect>
+ ] 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 <ast-define> ] action ;
+
+ MEMO: 'quotation' ( -- parser )
+ [
+ "[" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
++ 'expression' [ ast-expression-values ] action ,
+ "]" token sp hide ,
+ ] { } make seq [ first <ast-quotation> ] action ;
+
+ MEMO: 'array' ( -- parser )
+ [
+ "{" token sp hide ,
+ 'expression' [ ast-expression-values ] action ,
+ "}" token sp hide ,
+ ] { } make seq [ first <ast-array> ] action ;
+
+ MEMO: 'word' ( -- parser )
+ [
+ "\\" token sp hide ,
- 'identifier' sp ,
++ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value f <ast-word> ] action ;
+
+ MEMO: 'atom' ( -- parser )
+ [
- 'identifier' ,
++ 'identifier' ,
+ 'integer' [ <ast-number> ] action ,
+ 'string' [ <ast-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 <ast-comment> ] action ;
+
+ MEMO: 'USE:' ( -- parser )
+ [
+ "USE:" token sp hide ,
- 'identifier' sp ,
++ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value <ast-use> ] action ;
+
+ MEMO: 'IN:' ( -- parser )
+ [
+ "IN:" token sp hide ,
+ 'identifier' sp ,
+ ] { } make seq [ first ast-identifier-value <ast-in> ] action ;
+
+ MEMO: 'USING:' ( -- parser )
+ [
+ "USING:" token sp hide ,
+ 'identifier' sp [ ast-identifier-value ] action repeat1 ,
+ ";" token sp hide ,
+ ] { } make seq [ first <ast-using> ] action ;
+
+ MEMO: 'hashtable' ( -- parser )
+ [
+ "H{" token sp hide ,
- 'expression' [ ast-expression-values ] action ,
++ 'expression' [ ast-expression-values ] action ,
+ "}" token sp hide ,
+ ] { } make seq [ first <ast-hashtable> ] 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 [ <ast-expression> ] action
++ ] { } make choice repeat0 [ <ast-expression> ] action
+ ] delay ;
+
+ MEMO: 'statement' ( -- parser )
'expression' ;
GENERIC: (compile) ( ast -- )
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 }
}
: 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 ;
-
++
--- /dev/null
-{ $values
+ ! 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
-{ $description
++{ $values
+ { "object" "an object" } }
-{ $values
- { "string" "a string" }
- { "parser" "a peg based parser" }
- { "seq" "a sequence" }
++{ $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
-{ $description
++{ $values
++ { "string" "a string" }
++ { "parser" "a peg based parser" }
++ { "seq" "a sequence" }
+ }
-
++{ $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 } ;
-{ $values
- { "string" "a string" }
- { "parser" "a peg based parser" }
- { "result" "a string" }
++
+ HELP: replace
-{ $description
++{ $values
++ { "string" "a string" }
++ { "parser" "a peg based parser" }
++ { "result" "a string" }
+ }
-}
++{ $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 } ;
+
--- /dev/null
- "abc 123 def 456" 'integer' search
+ ! 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 } } [
- "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search
++ "abc 123 def 456" 'integer' search
+ ] unit-test
+
+ { V{ 123 "hello" 456 } } [
- "abc 123 def 456" 'integer' [ 2 * number>string ] action replace
++ "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
+ ] unit-test
+
--- /dev/null
-IN: peg.search
+ ! 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
+
+ : tree-write ( object -- )
- parse-result-ast [ ] subset
++ {
+ { [ 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
+ ] [
+ 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 ;
+
+
: 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 ;
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 ;
-! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel namespaces sequences words io assocs\r
-quotations strings parser arrays xml.data xml.writer debugger\r
-splitting vectors ;\r
-IN: xml.utilities\r
-\r
-! * System for words specialized on tag names\r
-\r
-TUPLE: process-missing process tag ;\r
-M: process-missing error.\r
- "Tag <" write\r
- dup process-missing-tag print-name\r
- "> not implemented on process process " write\r
- process-missing-process word-name print ;\r
-\r
-: run-process ( tag word -- )\r
- 2dup "xtable" word-prop\r
- >r dup name-tag r> at* [ 2nip call ] [\r
- drop \ process-missing construct-boa throw\r
- ] if ;\r
-\r
-: PROCESS:\r
- CREATE\r
- dup H{ } clone "xtable" set-word-prop\r
- dup [ run-process ] curry define-compound ; parsing\r
-\r
-: TAG:\r
- scan scan-word\r
- parse-definition\r
- swap "xtable" word-prop\r
- rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;\r
- parsing\r
-\r
-\r
-! * Common utility functions\r
-\r
-: build-tag* ( items name -- tag )\r
- assure-name swap >r f r> <tag> ;\r
-\r
-: build-tag ( item name -- tag )\r
- >r 1array r> build-tag* ;\r
-\r
-: standard-prolog ( -- prolog )\r
- T{ prolog f "1.0" "iso-8859-1" f } ;\r
-\r
-: build-xml ( tag -- xml )\r
- standard-prolog { } rot { } <xml> ;\r
-\r
-: children>string ( tag -- string )\r
- tag-children\r
- dup [ string? ] all?\r
- [ "XML tag unexpectedly contains non-text children" throw ] unless\r
- concat ;\r
-\r
-: children-tags ( tag -- sequence )\r
- tag-children [ tag? ] subset ;\r
-\r
-: first-child-tag ( tag -- tag )\r
- tag-children [ tag? ] find nip ;\r
-\r
-! * Utilities for searching through XML documents\r
-! These all work from the outside in, top to bottom.\r
-\r
-: with-delegate ( object quot -- object )\r
- over clone >r >r delegate r> call r>\r
- [ set-delegate ] keep ; inline\r
-\r
-GENERIC# xml-each 1 ( quot tag -- ) inline\r
-M: tag xml-each\r
- [ call ] 2keep\r
- swap tag-children [ swap xml-each ] curry* each ;\r
-M: object xml-each\r
- call ;\r
-M: xml xml-each\r
- >r delegate r> xml-each ;\r
-\r
-GENERIC# xml-map 1 ( quot tag -- tag ) inline\r
-M: tag xml-map\r
- swap clone over >r swap call r> \r
- swap [ tag-children [ swap xml-map ] curry* map ] keep \r
- [ set-tag-children ] keep ;\r
-M: object xml-map\r
- call ;\r
-M: xml xml-map\r
- swap [ swap xml-map ] with-delegate ;\r
-\r
-: xml-subset ( quot tag -- seq ) ! quot: tag -- ?\r
- V{ } clone rot [\r
- swap >r [ swap call ] 2keep rot r>\r
- swap [ [ push ] keep ] [ nip ] if\r
- ] xml-each nip ;\r
-\r
-GENERIC# xml-find 1 ( quot tag -- tag ) inline\r
-M: tag xml-find\r
- [ call ] 2keep swap rot [\r
- f swap\r
- [ nip over >r swap xml-find r> swap dup ] find\r
- 2drop ! leaves result of quot\r
- ] unless nip ;\r
-M: object xml-find\r
- keep f ? ;\r
-M: xml xml-find\r
- >r delegate r> xml-find ;\r
-\r
-GENERIC# xml-inject 1 ( quot tag -- ) inline\r
-M: tag xml-inject\r
- swap [\r
- swap [ call ] keep\r
- [ xml-inject ] keep\r
- ] change-each ;\r
-M: object xml-inject 2drop ;\r
-M: xml xml-inject >r delegate >r xml-inject ;\r
-\r
-! * Accessing part of an XML document\r
-! for tag- words, a start means that it searches all children\r
-! and no star searches only direct children\r
-\r
-: tag-named? ( name elem -- ? )\r
- dup tag? [ names-match? ] [ 2drop f ] if ;\r
-\r
-: tag-named* ( tag name/string -- matching-tag )\r
- assure-name swap [ dupd tag-named? ] xml-find nip ;\r
-\r
-: tags-named* ( tag name/string -- tags-seq )\r
- assure-name swap [ dupd tag-named? ] xml-subset nip ;\r
-\r
-: tag-named ( tag name/string -- matching-tag )\r
- ! like get-name-tag but only looks at direct children,\r
- ! not all the children down the tree.\r
- assure-name swap [ tag-named? ] curry* find nip ;\r
-\r
-: tags-named ( tag name/string -- tags-seq )\r
- assure-name swap [ tag-named? ] curry* subset ;\r
-\r
-: assert-tag ( name name -- )\r
- names-match? [ "Unexpected XML tag found" throw ] unless ;\r
-\r
-: insert-children ( children tag -- )\r
- dup tag-children [ push-all ]\r
- [ >r V{ } like r> set-tag-children ] if ;\r
-\r
-: insert-child ( child tag -- )\r
- >r 1vector r> insert-children ;\r
-\r
-: tag-with-attr? ( elem attr-value attr-name -- ? )\r
- rot dup tag? [ at = ] [ drop f ] if ;\r
-\r
-: tag-with-attr ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry find nip ;\r
-\r
-: tags-with-attr ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry subset ;\r
-\r
-: tag-with-attr* ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry xml-find nip ;\r
-\r
-: tags-with-attr* ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry xml-subset ;\r
-\r
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)\r
- "id" tag-with-attr ;\r
-\r
-: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )\r
- >r >r tags-named* r> r> tags-with-attr ;\r
-\r
+! 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 "" <name>
- swap >r { } r> <tag> ;
++ assure-name swap >r f r> <tag> ;
+
+: 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 { } <xml> ;
++ standard-prolog { } rot { } <xml> ;
+
+: 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 ;
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
}
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() {
projects / factor.git / commitdiff