--! Copyright (C) 2004, 2007 Slava Pestov.
++! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
"tombstone" "hashtables.private" lookup t
2array >tuple 1quotation define-inline
- { "<word>" "words.private" }
+! Primitive words
+: make-primitive ( word vocab n -- )
+ >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
+
+{
+ { "(execute)" "words.private" }
+ { "(call)" "kernel.private" }
+ { "uncurry" "kernel.private" }
+ { "string>sbuf" "sbufs.private" }
+ { "bignum>fixnum" "math.private" }
+ { "float>fixnum" "math.private" }
+ { "fixnum>bignum" "math.private" }
+ { "float>bignum" "math.private" }
+ { "fixnum>float" "math.private" }
+ { "bignum>float" "math.private" }
+ { "<ratio>" "math.private" }
+ { "string>float" "math.private" }
+ { "float>string" "math.private" }
+ { "float>bits" "math" }
+ { "double>bits" "math" }
+ { "bits>float" "math" }
+ { "bits>double" "math" }
+ { "<complex>" "math.private" }
+ { "fixnum+" "math.private" }
+ { "fixnum+fast" "math.private" }
+ { "fixnum-" "math.private" }
+ { "fixnum-fast" "math.private" }
+ { "fixnum*" "math.private" }
+ { "fixnum*fast" "math.private" }
+ { "fixnum/i" "math.private" }
+ { "fixnum-mod" "math.private" }
+ { "fixnum/mod" "math.private" }
+ { "fixnum-bitand" "math.private" }
+ { "fixnum-bitor" "math.private" }
+ { "fixnum-bitxor" "math.private" }
+ { "fixnum-bitnot" "math.private" }
+ { "fixnum-shift" "math.private" }
+ { "fixnum<" "math.private" }
+ { "fixnum<=" "math.private" }
+ { "fixnum>" "math.private" }
+ { "fixnum>=" "math.private" }
+ { "bignum=" "math.private" }
+ { "bignum+" "math.private" }
+ { "bignum-" "math.private" }
+ { "bignum*" "math.private" }
+ { "bignum/i" "math.private" }
+ { "bignum-mod" "math.private" }
+ { "bignum/mod" "math.private" }
+ { "bignum-bitand" "math.private" }
+ { "bignum-bitor" "math.private" }
+ { "bignum-bitxor" "math.private" }
+ { "bignum-bitnot" "math.private" }
+ { "bignum-shift" "math.private" }
+ { "bignum<" "math.private" }
+ { "bignum<=" "math.private" }
+ { "bignum>" "math.private" }
+ { "bignum>=" "math.private" }
+ { "bignum-bit?" "math.private" }
+ { "bignum-log2" "math.private" }
+ { "byte-array>bignum" "math" }
+ { "float=" "math.private" }
+ { "float+" "math.private" }
+ { "float-" "math.private" }
+ { "float*" "math.private" }
+ { "float/f" "math.private" }
+ { "float-mod" "math.private" }
+ { "float<" "math.private" }
+ { "float<=" "math.private" }
+ { "float>" "math.private" }
+ { "float>=" "math.private" }
++ { "<word>" "words" }
+ { "word-xt" "words" }
+ { "drop" "kernel" }
+ { "2drop" "kernel" }
+ { "3drop" "kernel" }
+ { "dup" "kernel" }
+ { "2dup" "kernel" }
+ { "3dup" "kernel" }
+ { "rot" "kernel" }
+ { "-rot" "kernel" }
+ { "dupd" "kernel" }
+ { "swapd" "kernel" }
+ { "nip" "kernel" }
+ { "2nip" "kernel" }
+ { "tuck" "kernel" }
+ { "over" "kernel" }
+ { "pick" "kernel" }
+ { "swap" "kernel" }
+ { ">r" "kernel" }
+ { "r>" "kernel" }
+ { "eq?" "kernel" }
+ { "getenv" "kernel.private" }
+ { "setenv" "kernel.private" }
+ { "(stat)" "io.files.private" }
+ { "(directory)" "io.files.private" }
+ { "data-gc" "memory" }
+ { "code-gc" "memory" }
+ { "gc-time" "memory" }
+ { "save-image" "memory" }
+ { "save-image-and-exit" "memory" }
+ { "datastack" "kernel" }
+ { "retainstack" "kernel" }
+ { "callstack" "kernel" }
+ { "set-datastack" "kernel" }
+ { "set-retainstack" "kernel" }
+ { "set-callstack" "kernel" }
+ { "exit" "system" }
+ { "data-room" "memory" }
+ { "code-room" "memory" }
+ { "os-env" "system" }
+ { "millis" "system" }
+ { "type" "kernel.private" }
+ { "tag" "kernel.private" }
+ { "cwd" "io.files" }
+ { "cd" "io.files" }
+ { "modify-code-heap" "words.private" }
+ { "dlopen" "alien" }
+ { "dlsym" "alien" }
+ { "dlclose" "alien" }
+ { "<byte-array>" "byte-arrays" }
+ { "<bit-array>" "bit-arrays" }
+ { "<displaced-alien>" "alien" }
+ { "alien-signed-cell" "alien" }
+ { "set-alien-signed-cell" "alien" }
+ { "alien-unsigned-cell" "alien" }
+ { "set-alien-unsigned-cell" "alien" }
+ { "alien-signed-8" "alien" }
+ { "set-alien-signed-8" "alien" }
+ { "alien-unsigned-8" "alien" }
+ { "set-alien-unsigned-8" "alien" }
+ { "alien-signed-4" "alien" }
+ { "set-alien-signed-4" "alien" }
+ { "alien-unsigned-4" "alien" }
+ { "set-alien-unsigned-4" "alien" }
+ { "alien-signed-2" "alien" }
+ { "set-alien-signed-2" "alien" }
+ { "alien-unsigned-2" "alien" }
+ { "set-alien-unsigned-2" "alien" }
+ { "alien-signed-1" "alien" }
+ { "set-alien-signed-1" "alien" }
+ { "alien-unsigned-1" "alien" }
+ { "set-alien-unsigned-1" "alien" }
+ { "alien-float" "alien" }
+ { "set-alien-float" "alien" }
+ { "alien-double" "alien" }
+ { "set-alien-double" "alien" }
+ { "alien-cell" "alien" }
+ { "set-alien-cell" "alien" }
+ { "alien>char-string" "alien" }
+ { "string>char-alien" "alien" }
+ { "alien>u16-string" "alien" }
+ { "string>u16-alien" "alien" }
+ { "(throw)" "kernel.private" }
+ { "string>memory" "alien" }
+ { "memory>string" "alien" }
+ { "alien-address" "alien" }
+ { "slot" "slots.private" }
+ { "set-slot" "slots.private" }
+ { "char-slot" "strings.private" }
+ { "set-char-slot" "strings.private" }
+ { "resize-array" "arrays" }
+ { "resize-string" "strings" }
+ { "(hashtable)" "hashtables.private" }
+ { "<array>" "arrays" }
+ { "begin-scan" "memory" }
+ { "next-object" "memory" }
+ { "end-scan" "memory" }
+ { "size" "memory" }
+ { "die" "kernel" }
+ { "fopen" "io.streams.c" }
+ { "fgetc" "io.streams.c" }
+ { "fread" "io.streams.c" }
+ { "fwrite" "io.streams.c" }
+ { "fflush" "io.streams.c" }
+ { "fclose" "io.streams.c" }
+ { "<wrapper>" "kernel" }
+ { "(clone)" "kernel" }
+ { "array>vector" "vectors.private" }
+ { "<string>" "strings" }
+ { "(>tuple)" "tuples.private" }
+ { "array>quotation" "quotations.private" }
+ { "quotation-xt" "quotations" }
+ { "<tuple>" "tuples.private" }
+ { "tuple>array" "tuples" }
+ { "profiling" "tools.profiler.private" }
+ { "become" "kernel.private" }
+ { "(sleep)" "threads.private" }
+ { "<float-array>" "float-arrays" }
+ { "curry" "kernel" }
+ { "<tuple-boa>" "tuples.private" }
+ { "class-hash" "kernel.private" }
+ { "callstack>array" "kernel" }
+ { "innermost-frame-quot" "kernel.private" }
+ { "innermost-frame-scan" "kernel.private" }
+ { "set-innermost-frame-quot" "kernel.private" }
+ { "call-clear" "kernel" }
+ { "(os-envs)" "system" }
+}
+dup length [ >r first2 r> make-primitive ] 2each
+
! Bump build number
-"build" "kernel" create build 1+ 1quotation define-compound
+"build" "kernel" create build 1+ 1quotation define
-! 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 sequences.deep ;\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
-! * 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
-: tags@ ( tag name -- children name )\r
- >r { } like r> assure-name ;\r
-\r
-: deep-tag-named ( tag name/string -- matching-tag )\r
- assure-name [ swap tag-named? ] curry deep-find ;\r
-\r
-: deep-tags-named ( tag name/string -- tags-seq )\r
- tags@ [ swap tag-named? ] curry deep-subset ;\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
- tags@ swap [ tag-named? ] curry* subset ;\r
-\r
-: tag-with-attr? ( elem attr-value attr-name -- ? )\r
- rot dup tag? [ at = ] [ 3drop 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
- tags@ [ tag-with-attr? ] 2curry subset tag-children ;\r
-\r
-: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry deep-find ;\r
-\r
-: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )\r
- tags@ [ tag-with-attr? ] 2curry deep-subset ;\r
-\r
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)\r
- "id" deep-tag-with-attr ;\r
-\r
-: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )\r
- >r >r deep-tags-named r> r> tags-with-attr ;\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
+! 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 ;
++splitting vectors sequences.deep ;
+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> <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 )
+ 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 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@ ( tag name -- children name )
++ >r { } like r> assure-name ;
++
++: deep-tag-named ( tag name/string -- matching-tag )
++ assure-name [ swap tag-named? ] curry deep-find ;
+
- : tags-named* ( tag name/string -- tags-seq )
- assure-name swap [ dupd tag-named? ] xml-subset nip ;
++: deep-tags-named ( tag name/string -- tags-seq )
++ tags@ [ swap tag-named? ] curry deep-subset ;
+
+: 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 ;
++ tags@ swap [ tag-named? ] curry* subset ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
- rot dup tag? [ at = ] [ drop f ] if ;
++ rot dup tag? [ at = ] [ 3drop 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 ;
++ tags@ [ tag-with-attr? ] 2curry subset tag-children ;
+
- : tag-with-attr* ( tag attr-value attr-name -- matching-tag )
- assure-name [ tag-with-attr? ] 2curry xml-find nip ;
++: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
++ assure-name [ tag-with-attr? ] 2curry deep-find ;
+
- : tags-with-attr* ( tag attr-value attr-name -- tags-seq )
- assure-name [ tag-with-attr? ] 2curry xml-subset ;
++: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
++ tags@ [ tag-with-attr? ] 2curry deep-subset ;
+
+: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
- "id" tag-with-attr ;
++ "id" deep-tag-with-attr ;
++
++: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
++ >r >r deep-tags-named r> r> tags-with-attr ;
++
++: assert-tag ( name name -- )
++ names-match? [ "Unexpected XML tag found" throw ] unless ;
+
- : tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
- >r >r tags-named* r> r> tags-with-attr ;
++: 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 ;
projects / factor.git / commitdiff