+++ /dev/null
-This is the infix minilanguage created by Daniel Ehrenberg, allowing you to do infix math in Factor. The syntax is simple: all infix are right-associative and parentheses may be used. There are also unary operators and operators which take arguments in square brackets seperated by semicolons. Infix operators are the ones that are made of non-alphabetic characters. To make a word that uses infix, the syntax is MATH: functionname[firstarg;secondarg;etc]=value ; Args are one or more variables that you use in the expression. Their values come from the stack. Variables are effectively substituted in to the expression. Any alphabetic string may be used as a variable. To make a new operator, just update the functions hashtable in the infix vocabulary. For more information, see the code or contact the author of this program. To close, here's an implementation of the quadratic formula using infix math. This is included in the module.
-
-MATH: quadratic[a;b;c] =
- plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
-
-If you find any bugs in this or have any questions, please contact me at microdan @ gmail . com, ask LittleDan@irc.freenode.net, or ask irc.freenode.net/#concatenative
+++ /dev/null
-IN: infix
-USING: sequences kernel io math strings combinators namespaces prettyprint
- errors parser generic lists kernel-internals hashtables words vectors ;
-
-! Tokenizer
-
-TUPLE: tok char ;
-
-TUPLE: brackets seq ender ;
-
-SYMBOL: apostrophe
-
-SYMBOL: code #! Source code
-SYMBOL: spot #! Current index of string
-
-: take-until ( quot -- parsed-stuff | quot: char -- ? )
- #! Take the substring of a string starting at spot
- #! from code until the quotation given is true and
- #! advance spot to after the substring.
- >r spot get code get 2dup r>
- skip [ swap subseq ] keep
- spot set ;
-
-: parse-blank ( -- )
- #! Advance code past any whitespace, including newlines
- spot get code get [ blank? not ] skip spot set ;
-
-: not-done? ( -- ? )
- #! Return t if spot is not at the end of code
- code get length spot get = not ;
-
-: incr-spot ( -- )
- #! Increment spot.
- spot [ 1 + ] change ;
-
-: parse-var ( -- variable-name )
- #! Take a series of letters from code, advancing
- #! spot and returning the letters.
- [ letter? not ] take-until ;
-
-: parse-num ( -- number )
- #! Take a number from code, advancing spot and
- #! returning the number.
- [ "0123456789." member? not ] take-until string>number ;
-
-: get-token ( -- char )
- spot get code get nth ;
-
-DEFER: token
-
-: next-token ( list -- list )
- #! Take one token from code and return it
- parse-blank not-done? [
- get-token token
- ] when ;
-
-: token
- {
- { [ dup letter? ] [ drop parse-var swons ] }
- { [ dup "0123456789." member? ] [ drop parse-num swons ] }
- { [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ <tok> swons incr-spot ] }
- { [ dup "([{" member? ] [ drop f incr-spot ] }
- { [ dup ")]}" member? ] [ <brackets> swons incr-spot ] }
- { [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
- { [ t ] [ "Bad character " swap ch>string append throw ] }
- } cond next-token ;
-
-: tokenize ( string -- tokens )
- #! Tokenize a string, returning a list of tokens
- [
- code set 0 spot set
- f next-token reverse
- ] with-scope ;
-
-
-! Parser
-
-TUPLE: apply func args ;
- #! Function application
-C: apply
- >r [ ] subset r>
- [ set-apply-args ] keep
- [ set-apply-func ] keep ;
-
-UNION: value number string ;
-
-: semicolon ( -- semicolon )
- #! The semicolon token
- << tok f CHAR: ; >> ;
-
-: nest-apply ( [ ast ] -- apply )
- unswons unit swap [
- swap <apply> unit
- ] each car ;
-
-GENERIC: parse-token ( ast tokens token -- ast tokens )
- #! Take one or more tokens
-
-DEFER: parse-tokens
-
-: semicolon-split ( list -- [ ast ] )
- reverse semicolon unit split [ parse-tokens ] map ;
-
-M: value parse-token
- swapd swons swap ;
-
-M: brackets parse-token
- swapd dup brackets-seq swap brackets-ender {
- { [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> <apply> swons ] }
- { [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
- { [ CHAR: ) = ] [ reverse parse-tokens swons ] }
- } cond swap ;
-
-M: object tok-char drop -1 ; ! Hack!
-
-GENERIC: tok>string ( token/string -- string )
-M: tok tok>string
- tok-char ch>string ;
-M: string tok>string ;
-
-: binary-op ( ast tokens token -- ast )
- >r >r unswons r> parse-tokens 2list r>
- tok>string swap <apply> swons ;
-
-: unary-op ( ast tokens token -- ast )
- tok>string -rot nip
- parse-tokens unit <apply> unit ;
-
-: null-op ( ast tokens token -- ast )
- nip tok-char ch>string swons ;
-
-M: tok parse-token
- over [
- pick [
- binary-op
- ] [
- unary-op
- ] ifte
- ] [
- null-op
- ] ifte f ;
-
-( ast tokens token -- ast tokens )
-
-M: symbol parse-token ! apostrophe
- drop unswons >r parse-tokens >r unswons r> 2list r>
- unit parse-tokens swap <apply> swons f ;
-
-: (parse-tokens) ( ast tokens -- ast )
- dup [
- unswons parse-token (parse-tokens)
- ] [
- drop
- ] ifte ;
-
-: parse-tokens ( tokens -- ast )
- #! Convert a list of tokens into an AST
- f swap (parse-tokens) nest-apply ;
-
-: parse-full ( string -- ast )
- #! Convert a string into an AST
- tokenize parse-tokens ;
-
-
-! Compiler
-
-GENERIC: compile-ast ( vars ast -- quot )
-
-M: string compile-ast ! variables
- swap index dup -1 = [
- "Variable not found" throw
- ] [
- [ swap array-nth ] cons
- ] ifte ;
-
-: replace-with ( data -- [ drop data ] )
- \ drop swap 2list ;
-
-UNION: comp-literal number general-list ;
-
-M: comp-literal compile-ast ! literal numbers
- replace-with nip ;
-
-: accumulator ( vars { asts } quot -- quot )
- -rot [
- [
- \ dup ,
- compile-ast %
- dup %
- ] each-with
- ] [ ] make nip ;
-
-M: vector compile-ast ! literal vectors
- dup [ number? ] all? [
- replace-with nip
- ] [
- [ , ] accumulator [ { } make nip ] cons
- ] ifte ;
-
-: infix-relation
- #! Wraps operators like = and > so that if they're given
- #! f as either argument, they return f, and they return f if
- #! the operation yields f, but if it yields t, it returns the
- #! left argument. This way, these types of operations can be
- #! composed.
- >r 2dup and not [
- r> 3drop f
- ] [
- dupd r> call [
- drop f
- ] unless
- ] ifte ;
-
-: functions
- #! Regular functions
- #! Gives quotation applicable to stack
- {{
- [ [[ "+" 2 ]] + ]
- [ [[ "-" 2 ]] - ]
- [ [[ ">" 2 ]] [ > ] infix-relation ]
- [ [[ "<" 2 ]] [ < ] infix-relation ]
- [ [[ "=" 2 ]] [ = ] infix-relation ]
- [ [[ "-" 1 ]] neg ]
- [ [[ "~" 1 ]] not ]
- [ [[ "&" 2 ]] and ]
- [ [[ "|" 2 ]] or ]
- [ [[ "&" 1 ]] t [ and ] reduce ]
- [ [[ "|" 1 ]] f [ or ] reduce ]
- [ [[ "*" 2 ]] * ]
- [ [[ "ln" 1 ]] log ]
- [ [[ "plusmin" 2 ]] [ + ] 2keep - ]
- [ [[ "@" 2 ]] swap nth ]
- [ [[ "sqrt" 1 ]] sqrt ]
- [ [[ "/" 2 ]] / ]
- [ [[ "^" 2 ]] ^ ]
- [ [[ "#" 1 ]] length ]
- [ [[ "eq" 2 ]] eq? ]
- [ [[ "*" 1 ]] first ]
- [ [[ "+" 1 ]] flip ]
- [ [[ "\\" 1 ]] <reversed> ]
- [ [[ "sin" 1 ]] sin ]
- [ [[ "cos" 1 ]] cos ]
- [ [[ "tan" 1 ]] tan ]
- [ [[ "max" 2 ]] max ]
- [ [[ "min" 2 ]] min ]
- [ [[ "," 2 ]] append ]
- [ [[ "," 1 ]] concat ]
- [ [[ "sn" 3 ]] -rot set-nth ]
- [ [[ "prod" 1 ]] product ]
- [ [[ "vec" 1 ]] >vector ]
- }} ;
-
-: drc ( list -- list )
- #! all of list except last element (backwards cdr)
- dup cdr [
- uncons drc cons
- ] [
- drop f
- ] ifte ;
-
-: map-with-left ( seq object quot -- seq )
- [ swapd call ] cons swapd map-with ; inline
-
-: high-functions
- #! Higher-order functions
- #! Gives quotation applicable to quotation and rest of stack
- {{
- [ [[ "!" 2 ]] 2map ]
- [ [[ "!" 1 ]] map ]
- [ [[ ">" 2 ]] map-with ]
- [ [[ "<" 2 ]] map-with-left ]
- [ [[ "^" 1 ]] all? ]
- [ [[ "~" 1 ]] call not ]
- [ [[ "~" 2 ]] call not ]
- [ [[ "/" 2 ]] swapd reduce ]
- [ [[ "\\" 2 ]] swapd accumulate ]
- }} ;
-
-: get-hash ( key table -- value )
- #! like hash but throws exception if f
- dupd hash [ nip ] [
- [ "Key not found " write . ] string-out throw
- ] ifte* ;
-
-: >apply< ( apply -- func args )
- dup apply-func swap apply-args ;
-
-: make-apply ( arity apply/string -- quot )
- dup string? [
- swons functions get-hash
- ] [
- >apply< car >r over r> make-apply
- -rot swons high-functions get-hash cons
- ] ifte ;
-
-: get-function ( apply -- quot )
- >apply< length swap make-apply ;
-
-M: apply compile-ast ! function application
- [ apply-args [ swap ] accumulator [ drop ] append ] keep
- get-function append ;
-
-: push-list ( list item -- list )
- unit append ;
-
-: parse-comp ( args string -- quot )
- #! Compile a string into a quotation w/o prologue
- parse-full compile-ast ;
-
-: prologue ( args -- quot )
- #! Build the prolog for a function
- [
- length dup , \ <array> ,
- [ 1 - ] keep [
- 2dup - [ swap set-array-nth ] cons , \ keep ,
- ] repeat drop
- ] [ ] make ;
-
-: ast>quot ( args ast -- quot )
- over prologue -rot compile-ast append ;
-
-: define-math ( seq -- )
- " " join
- dup parse-full apply-args uncons car swap
- >apply< >r create-in r>
- [ "math-args" set-word-prop ] 2keep
- >r tuck >r >r swap "code" set-word-prop r> r> r>
- rot ast>quot define-compound ;
-
-: MATH:
- #! MATH: sq[x]=x*x ;
- "in-definition" on
- string-mode on
- [
- string-mode off define-math
- ] f ; parsing
-
-: TEST-MATH:
- #! Executes and prints the result of a math
- #! expression at parsetime
- string-mode on [
- " " join string-mode off parse-full
- f swap ast>quot call .
- ] f ; parsing
-
-! PREDICATE: compound infix-word "code" word-prop ;
-! M: infix-word definer
-! drop POSTPONE: MATH: ;
-! M: infix-word class.
-! "code" word-prop write " ;" print ;
-!
-! Redefine compound to not include infix words so see works
-! IN: words
-! USING: kernel words parse-k ;
-!
-! PREDICATE: word compound
-! dup word-primitive 1 = swap infix-word? not and ;
-
-
-
-MATH: quadratic[a;b;c] =
- plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
--- /dev/null
+This is the infix minilanguage created by Daniel Ehrenberg, allowing you to do infix math in Factor. The syntax is simple: all infix are right-associative and parentheses may be used. There are also unary operators and operators which take arguments in square brackets seperated by semicolons. Infix operators are the ones that are made of non-alphabetic characters. To make a word that uses infix, the syntax is MATH: functionname[firstarg;secondarg;etc]=value ; Args are one or more variables that you use in the expression. Their values come from the stack. Variables are effectively substituted in to the expression. Any alphabetic string may be used as a variable. To make a new operator, just update the functions hashtable in the infix vocabulary. For more information, see the code or contact the author of this program. To close, here's an implementation of the quadratic formula using infix math. This is included in the module.
+
+MATH: quadratic[a;b;c] =
+ plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
+
+If you find any bugs in this or have any questions, please contact me at microdan @ gmail . com, ask LittleDan@irc.freenode.net, or ask irc.freenode.net/#concatenative
--- /dev/null
+IN: infix
+USING: sequences kernel io math strings combinators namespaces prettyprint
+ errors parser generic lists kernel-internals hashtables words vectors ;
+
+! Tokenizer
+
+TUPLE: tok char ;
+
+TUPLE: brackets seq ender ;
+
+SYMBOL: apostrophe
+
+SYMBOL: code #! Source code
+SYMBOL: spot #! Current index of string
+
+: take-until ( quot -- parsed-stuff | quot: char -- ? )
+ #! Take the substring of a string starting at spot
+ #! from code until the quotation given is true and
+ #! advance spot to after the substring.
+ >r spot get code get 2dup r>
+ skip [ swap subseq ] keep
+ spot set ;
+
+: parse-blank ( -- )
+ #! Advance code past any whitespace, including newlines
+ spot get code get [ blank? not ] skip spot set ;
+
+: not-done? ( -- ? )
+ #! Return t if spot is not at the end of code
+ code get length spot get = not ;
+
+: incr-spot ( -- )
+ #! Increment spot.
+ spot [ 1 + ] change ;
+
+: parse-var ( -- variable-name )
+ #! Take a series of letters from code, advancing
+ #! spot and returning the letters.
+ [ letter? not ] take-until ;
+
+: parse-num ( -- number )
+ #! Take a number from code, advancing spot and
+ #! returning the number.
+ [ "0123456789." member? not ] take-until string>number ;
+
+: get-token ( -- char )
+ spot get code get nth ;
+
+DEFER: token
+
+: next-token ( list -- list )
+ #! Take one token from code and return it
+ parse-blank not-done? [
+ get-token token
+ ] when ;
+
+: token
+ {
+ { [ dup letter? ] [ drop parse-var swons ] }
+ { [ dup "0123456789." member? ] [ drop parse-num swons ] }
+ { [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ <tok> swons incr-spot ] }
+ { [ dup "([{" member? ] [ drop f incr-spot ] }
+ { [ dup ")]}" member? ] [ <brackets> swons incr-spot ] }
+ { [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
+ { [ t ] [ "Bad character " swap ch>string append throw ] }
+ } cond next-token ;
+
+: tokenize ( string -- tokens )
+ #! Tokenize a string, returning a list of tokens
+ [
+ code set 0 spot set
+ f next-token reverse
+ ] with-scope ;
+
+
+! Parser
+
+TUPLE: apply func args ;
+ #! Function application
+C: apply
+ >r [ ] subset r>
+ [ set-apply-args ] keep
+ [ set-apply-func ] keep ;
+
+UNION: value number string ;
+
+: semicolon ( -- semicolon )
+ #! The semicolon token
+ << tok f CHAR: ; >> ;
+
+: nest-apply ( [ ast ] -- apply )
+ unswons unit swap [
+ swap <apply> unit
+ ] each car ;
+
+GENERIC: parse-token ( ast tokens token -- ast tokens )
+ #! Take one or more tokens
+
+DEFER: parse-tokens
+
+: semicolon-split ( list -- [ ast ] )
+ reverse semicolon unit split [ parse-tokens ] map ;
+
+M: value parse-token
+ swapd swons swap ;
+
+M: brackets parse-token
+ swapd dup brackets-seq swap brackets-ender {
+ { [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> <apply> swons ] }
+ { [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
+ { [ CHAR: ) = ] [ reverse parse-tokens swons ] }
+ } cond swap ;
+
+M: object tok-char drop -1 ; ! Hack!
+
+GENERIC: tok>string ( token/string -- string )
+M: tok tok>string
+ tok-char ch>string ;
+M: string tok>string ;
+
+: binary-op ( ast tokens token -- ast )
+ >r >r unswons r> parse-tokens 2list r>
+ tok>string swap <apply> swons ;
+
+: unary-op ( ast tokens token -- ast )
+ tok>string -rot nip
+ parse-tokens unit <apply> unit ;
+
+: null-op ( ast tokens token -- ast )
+ nip tok-char ch>string swons ;
+
+M: tok parse-token
+ over [
+ pick [
+ binary-op
+ ] [
+ unary-op
+ ] ifte
+ ] [
+ null-op
+ ] ifte f ;
+
+( ast tokens token -- ast tokens )
+
+M: symbol parse-token ! apostrophe
+ drop unswons >r parse-tokens >r unswons r> 2list r>
+ unit parse-tokens swap <apply> swons f ;
+
+: (parse-tokens) ( ast tokens -- ast )
+ dup [
+ unswons parse-token (parse-tokens)
+ ] [
+ drop
+ ] ifte ;
+
+: parse-tokens ( tokens -- ast )
+ #! Convert a list of tokens into an AST
+ f swap (parse-tokens) nest-apply ;
+
+: parse-full ( string -- ast )
+ #! Convert a string into an AST
+ tokenize parse-tokens ;
+
+
+! Compiler
+
+GENERIC: compile-ast ( vars ast -- quot )
+
+M: string compile-ast ! variables
+ swap index dup -1 = [
+ "Variable not found" throw
+ ] [
+ [ swap array-nth ] cons
+ ] ifte ;
+
+: replace-with ( data -- [ drop data ] )
+ \ drop swap 2list ;
+
+UNION: comp-literal number general-list ;
+
+M: comp-literal compile-ast ! literal numbers
+ replace-with nip ;
+
+: accumulator ( vars { asts } quot -- quot )
+ -rot [
+ [
+ \ dup ,
+ compile-ast %
+ dup %
+ ] each-with
+ ] [ ] make nip ;
+
+M: vector compile-ast ! literal vectors
+ dup [ number? ] all? [
+ replace-with nip
+ ] [
+ [ , ] accumulator [ { } make nip ] cons
+ ] ifte ;
+
+: infix-relation
+ #! Wraps operators like = and > so that if they're given
+ #! f as either argument, they return f, and they return f if
+ #! the operation yields f, but if it yields t, it returns the
+ #! left argument. This way, these types of operations can be
+ #! composed.
+ >r 2dup and not [
+ r> 3drop f
+ ] [
+ dupd r> call [
+ drop f
+ ] unless
+ ] ifte ;
+
+: functions
+ #! Regular functions
+ #! Gives quotation applicable to stack
+ {{
+ [ [[ "+" 2 ]] + ]
+ [ [[ "-" 2 ]] - ]
+ [ [[ ">" 2 ]] [ > ] infix-relation ]
+ [ [[ "<" 2 ]] [ < ] infix-relation ]
+ [ [[ "=" 2 ]] [ = ] infix-relation ]
+ [ [[ "-" 1 ]] neg ]
+ [ [[ "~" 1 ]] not ]
+ [ [[ "&" 2 ]] and ]
+ [ [[ "|" 2 ]] or ]
+ [ [[ "&" 1 ]] t [ and ] reduce ]
+ [ [[ "|" 1 ]] f [ or ] reduce ]
+ [ [[ "*" 2 ]] * ]
+ [ [[ "ln" 1 ]] log ]
+ [ [[ "plusmin" 2 ]] [ + ] 2keep - ]
+ [ [[ "@" 2 ]] swap nth ]
+ [ [[ "sqrt" 1 ]] sqrt ]
+ [ [[ "/" 2 ]] / ]
+ [ [[ "^" 2 ]] ^ ]
+ [ [[ "#" 1 ]] length ]
+ [ [[ "eq" 2 ]] eq? ]
+ [ [[ "*" 1 ]] first ]
+ [ [[ "+" 1 ]] flip ]
+ [ [[ "\\" 1 ]] <reversed> ]
+ [ [[ "sin" 1 ]] sin ]
+ [ [[ "cos" 1 ]] cos ]
+ [ [[ "tan" 1 ]] tan ]
+ [ [[ "max" 2 ]] max ]
+ [ [[ "min" 2 ]] min ]
+ [ [[ "," 2 ]] append ]
+ [ [[ "," 1 ]] concat ]
+ [ [[ "sn" 3 ]] -rot set-nth ]
+ [ [[ "prod" 1 ]] product ]
+ [ [[ "vec" 1 ]] >vector ]
+ }} ;
+
+: drc ( list -- list )
+ #! all of list except last element (backwards cdr)
+ dup cdr [
+ uncons drc cons
+ ] [
+ drop f
+ ] ifte ;
+
+: map-with-left ( seq object quot -- seq )
+ [ swapd call ] cons swapd map-with ; inline
+
+: high-functions
+ #! Higher-order functions
+ #! Gives quotation applicable to quotation and rest of stack
+ {{
+ [ [[ "!" 2 ]] 2map ]
+ [ [[ "!" 1 ]] map ]
+ [ [[ ">" 2 ]] map-with ]
+ [ [[ "<" 2 ]] map-with-left ]
+ [ [[ "^" 1 ]] all? ]
+ [ [[ "~" 1 ]] call not ]
+ [ [[ "~" 2 ]] call not ]
+ [ [[ "/" 2 ]] swapd reduce ]
+ [ [[ "\\" 2 ]] swapd accumulate ]
+ }} ;
+
+: get-hash ( key table -- value )
+ #! like hash but throws exception if f
+ dupd hash [ nip ] [
+ [ "Key not found " write . ] string-out throw
+ ] ifte* ;
+
+: >apply< ( apply -- func args )
+ dup apply-func swap apply-args ;
+
+: make-apply ( arity apply/string -- quot )
+ dup string? [
+ swons functions get-hash
+ ] [
+ >apply< car >r over r> make-apply
+ -rot swons high-functions get-hash cons
+ ] ifte ;
+
+: get-function ( apply -- quot )
+ >apply< length swap make-apply ;
+
+M: apply compile-ast ! function application
+ [ apply-args [ swap ] accumulator [ drop ] append ] keep
+ get-function append ;
+
+: push-list ( list item -- list )
+ unit append ;
+
+: parse-comp ( args string -- quot )
+ #! Compile a string into a quotation w/o prologue
+ parse-full compile-ast ;
+
+: prologue ( args -- quot )
+ #! Build the prolog for a function
+ [
+ length dup , \ <array> ,
+ [ 1 - ] keep [
+ 2dup - [ swap set-array-nth ] cons , \ keep ,
+ ] repeat drop
+ ] [ ] make ;
+
+: ast>quot ( args ast -- quot )
+ over prologue -rot compile-ast append ;
+
+: define-math ( seq -- )
+ " " join
+ dup parse-full apply-args uncons car swap
+ >apply< >r create-in r>
+ [ "math-args" set-word-prop ] 2keep
+ >r tuck >r >r swap "code" set-word-prop r> r> r>
+ rot ast>quot define-compound ;
+
+: MATH:
+ #! MATH: sq[x]=x*x ;
+ "in-definition" on
+ string-mode on
+ [
+ string-mode off define-math
+ ] f ; parsing
+
+: TEST-MATH:
+ #! Executes and prints the result of a math
+ #! expression at parsetime
+ string-mode on [
+ " " join string-mode off parse-full
+ f swap ast>quot call .
+ ] f ; parsing
+
+! PREDICATE: compound infix-word "code" word-prop ;
+! M: infix-word definer
+! drop POSTPONE: MATH: ;
+! M: infix-word class.
+! "code" word-prop write " ;" print ;
+!
+! Redefine compound to not include infix words so see works
+! IN: words
+! USING: kernel words parse-k ;
+!
+! PREDICATE: word compound
+! dup word-primitive 1 = swap infix-word? not and ;
+
+
+
+MATH: quadratic[a;b;c] =
+ plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
USING: kernel math infix parser namespaces sequences strings prettyprint
- errors lists hashtables vectors html io generic ;
+ errors lists hashtables vectors html io generic words ;
IN: xml
! * Simple SAX-ish parser
[ contained-name ] keep contained-props 0 <vector> <tag> push-datum ;
M: opener process
- 10 <vector> cons
+ { } clone cons
xml-stack get push ;
M: closer process
] keep opener-props r> <tag> push-datum ;
: initialize-xml-stack ( -- )
- f 10 <vector> cons unit >vector xml-stack set ;
+ f { } clone cons unit >vector xml-stack set ;
: xml ( string -- vector )
#! Produces a tree of XML nodes
[ process ] xml-each
xml-stack get
dup length 1 = [ <unclosed> throw ] unless
- first cdr
+ first cdr second
] with-scope ;
! * Printer
"-->" % ;
: xml>string ( xml -- string )
- [ [ (xml>string) ] each ] "" make ;
+ [ (xml>string) ] "" make ;
: xml-reprint ( string -- string )
xml xml>string ;
! * Easy XML generation for more literal things
+! should this be rewritten?
: text ( string -- )
chars>entities push-datum ;
initialize-xml-stack
call
xml-stack get
- first cdr
+ first cdr second
] with-scope ; inline
+
+! * System for words specialized on tag names
+
+: PROCESS:
+ CREATE
+ dup {{ }} clone "xtable" set-word-prop
+ dup literalize [
+ "xtable" word-prop
+ >r dup tag-name r> hash call
+ ] cons define-compound ; parsing
+
+: TAG:
+ scan scan-word [
+ swap "xtable" word-prop
+ rot "/" split [ >r 2dup r> swap set-hash ] each 2drop
+ ] f ; parsing
projects / factor.git / commitdiff