Merge branch 'master' into new_ui

db4
Slava Pestov 2009-01-28 15:41:08 -06:00
commit 6eebc66be4
31 changed files with 249 additions and 97 deletions

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary USING: combinators io io.binary io.encodings.binary
io.streams.byte-array io.streams.string kernel math namespaces io.streams.byte-array io.streams.string kernel math namespaces
sequences strings ; sequences strings io.crlf ;
IN: base64 IN: base64
<PRIVATE <PRIVATE
@ -32,7 +32,7 @@ SYMBOL: column
: write1-lines ( ch -- ) : write1-lines ( ch -- )
write1 write1
column get [ column get [
1+ [ 76 = [ "\r\n" write ] when ] 1+ [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi [ 76 mod column set ] bi
] when* ; ] when* ;

2
basis/base64/tags.txt Normal file
View File

@ -0,0 +1,2 @@
parsing
web

View File

@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
WHERE WHERE
: WW W twice ; inline : WW ( a -- b ) \ W twice ; inline
;FUNCTOR ;FUNCTOR

View File

@ -1,17 +1,42 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations classes.tuple make combinators generic USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser effects.parser locals.types locals.parser
locals.rewrite.closures vocabs.parser ; locals.rewrite.closures vocabs.parser arrays accessors ;
IN: functors IN: functors
! This is a hack
: scan-param ( -- obj ) : scan-param ( -- obj )
scan-object dup special? [ literalize ] unless ; scan-object dup special? [ literalize ] unless ;
: define* ( word def effect -- ) pick set-word define-declared ; : define* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake )
M: callable >fake-quotations
>array >fake-quotations fake-quotation boa ;
M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
M: fake-quotation fake-quotations>
seq>> [ fake-quotations> ] map >quotation ;
M: array fake-quotations> [ fake-quotations> ] map ;
M: object fake-quotations> ;
: parse-definition* ( -- )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
: `TUPLE: : `TUPLE:
@ -32,7 +57,7 @@ IN: functors
scan-param parsed scan-param parsed
scan-param parsed scan-param parsed
\ create-method parsed \ create-method parsed
parse-definition parsed parse-definition*
DEFINE* ; parsing DEFINE* ; parsing
: `C: : `C:
@ -45,7 +70,7 @@ IN: functors
: `: : `:
effect off effect off
scan-param parsed scan-param parsed
parse-definition parsed parse-definition*
DEFINE* ; parsing DEFINE* ; parsing
: `INSTANCE: : `INSTANCE:

View File

@ -6,7 +6,7 @@ quotations arrays byte-arrays math.parser calendar
calendar.format present urls calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit io.encodings.8-bit io.crlf
unicode.case unicode.categories unicode.case unicode.categories
@ -16,12 +16,6 @@ EXCLUDE: fry => , ;
IN: http IN: http
: crlf ( -- ) "\r\n" write ;
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: (read-header) ( -- alist ) : (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;

View File

@ -0,0 +1,2 @@
Daniel Ehrenberg
Slava Pestov

View File

@ -0,0 +1,12 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup sequences ;
IN: io.crlf
HELP: crlf
{ $values }
{ $description "Prints a carriage return and line feed to the current output stream, used to indicate a newline for certain network protocols." } ;
HELP: read-crlf
{ $values { "seq" sequence } }
{ $description "Reads until the next CRLF (carriage return followed by line feed) from the current input stream, throwing an error if there is not a CRLF remaining, or if CR is present without immediately being followed by LF." } ;

11
basis/io/crlf/crlf.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel ;
IN: io.crlf
: crlf ( -- )
"\r\n" write ;
: read-crlf ( -- seq )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;

View File

@ -0,0 +1 @@
Writing and reading until \r\n

View File

@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file
WHERE WHERE
: <mapped-A> ( mapped-file -- direct-array ) : <mapped-A> ( mapped-file -- direct-array )
T mapped-file>direct <A> execute ; inline T mapped-file>direct <A> ; inline
: with-mapped-A-file ( path length quot -- ) : with-mapped-A-file ( path length quot -- )
'[ <mapped-A> execute @ ] with-mapped-file ; inline '[ <mapped-A> @ ] with-mapped-file ; inline
;FUNCTOR ;FUNCTOR

View File

@ -494,4 +494,6 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
! Discovered by littledan ! Discovered by littledan
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test

View File

@ -37,7 +37,7 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: wrapper rewrite-literal? drop t ; M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
M: hashtable rewrite-literal? drop t ; M: hashtable rewrite-literal? drop t ;
@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- )
[ rewrite-element ] each ; [ rewrite-element ] each ;
: rewrite-sequence ( seq -- ) : rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
M: array rewrite-element M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
M: quotation rewrite-element rewrite-sugar* ; M: quotation rewrite-element rewrite-sugar* ;
@ -84,7 +84,7 @@ M: local-word rewrite-element
M: word rewrite-element literalize , ; M: word rewrite-element literalize , ;
M: wrapper rewrite-element M: wrapper rewrite-element
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ;
M: object rewrite-element , ; M: object rewrite-element , ;
@ -98,7 +98,8 @@ M: def rewrite-sugar* , ;
M: hashtable rewrite-sugar* rewrite-element ; M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper rewrite-sugar* rewrite-element ; M: wrapper rewrite-sugar*
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
M: word rewrite-sugar* M: word rewrite-sugar*
dup { load-locals get-local drop-locals } memq? dup { load-locals get-local drop-locals } memq?

View File

@ -1,3 +1,2 @@
math math
bindings bindings
unportable

View File

@ -268,28 +268,28 @@ TUPLE: MATRIX < blas-matrix-base ;
M: MATRIX element-type M: MATRIX element-type
drop TYPE ; drop TYPE ;
M: MATRIX (blas-matrix-like) M: MATRIX (blas-matrix-like)
drop <MATRIX> execute ; drop <MATRIX> ;
M: VECTOR (blas-matrix-like) M: VECTOR (blas-matrix-like)
drop <MATRIX> execute ; drop <MATRIX> ;
M: MATRIX (blas-vector-like) M: MATRIX (blas-vector-like)
drop <VECTOR> execute ; drop <VECTOR> ;
: >MATRIX ( arrays -- matrix ) : >MATRIX ( arrays -- matrix )
[ >ARRAY execute underlying>> ] (>matrix) [ >ARRAY underlying>> ] (>matrix)
<MATRIX> execute ; <MATRIX> ;
M: VECTOR n*M.V+n*V! M: VECTOR n*M.V+n*V!
[ TYPE>ARG execute ] (prepare-gemv) [ TYPE>ARG ] (prepare-gemv)
[ XGEMV execute ] dip ; [ XGEMV ] dip ;
M: MATRIX n*M.M+n*M! M: MATRIX n*M.M+n*M!
[ TYPE>ARG execute ] (prepare-gemm) [ TYPE>ARG ] (prepare-gemm)
[ XGEMM execute ] dip ; [ XGEMM ] dip ;
M: MATRIX n*V(*)V+M! M: MATRIX n*V(*)V+M!
[ TYPE>ARG execute ] (prepare-ger) [ TYPE>ARG ] (prepare-ger)
[ XGERU execute ] dip ; [ XGERU ] dip ;
M: MATRIX n*V(*)Vconj+M! M: MATRIX n*V(*)Vconj+M!
[ TYPE>ARG execute ] (prepare-ger) [ TYPE>ARG ] (prepare-ger)
[ XGERC execute ] dip ; [ XGERC ] dip ;
;FUNCTOR ;FUNCTOR

View File

@ -1,3 +1,2 @@
math math
bindings bindings
unportable

View File

@ -1,5 +1,5 @@
USING: kernel math.blas.vectors math.blas.matrices parser USING: kernel math.blas.vectors math.blas.matrices parser
arrays prettyprint.backend sequences ; arrays prettyprint.backend prettyprint.custom sequences ;
IN: math.blas.syntax IN: math.blas.syntax
: svector{ : svector{

View File

@ -1,2 +1 @@
math math
unportable

View File

@ -1,2 +1 @@
math math
unportable

View File

@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ;
: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline : <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
: >VECTOR ( seq -- v ) : >VECTOR ( seq -- v )
[ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ; [ >ARRAY underlying>> ] [ length ] bi 1 <VECTOR> ;
M: VECTOR clone M: VECTOR clone
TYPE heap-size (prepare-copy) TYPE heap-size (prepare-copy)
[ XCOPY execute ] 3dip <VECTOR> execute ; [ XCOPY ] 3dip <VECTOR> ;
M: VECTOR element-type M: VECTOR element-type
drop TYPE ; drop TYPE ;
M: VECTOR Vswap M: VECTOR Vswap
(prepare-swap) [ XSWAP execute ] 2dip ; (prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax M: VECTOR Viamax
(prepare-nrm2) IXAMAX execute ; (prepare-nrm2) IXAMAX ;
M: VECTOR (blas-vector-like) M: VECTOR (blas-vector-like)
drop <VECTOR> execute ; drop <VECTOR> ;
M: VECTOR (blas-direct-array) M: VECTOR (blas-direct-array)
[ underlying>> ] [ underlying>> ]
[ [ length>> ] [ inc>> ] bi * ] bi [ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> execute ; <DIRECT-ARRAY> ;
;FUNCTOR ;FUNCTOR
@ -180,17 +180,17 @@ XSCAL IS cblas_${T}scal
WHERE WHERE
M: VECTOR V. M: VECTOR V.
(prepare-dot) XDOT execute ; (prepare-dot) XDOT ;
M: VECTOR V.conj M: VECTOR V.conj
(prepare-dot) XDOT execute ; (prepare-dot) XDOT ;
M: VECTOR Vnorm M: VECTOR Vnorm
(prepare-nrm2) XNRM2 execute ; (prepare-nrm2) XNRM2 ;
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XASUM execute ; (prepare-nrm2) XASUM ;
M: VECTOR n*V+V! M: VECTOR n*V+V!
(prepare-axpy) [ XAXPY execute ] dip ; (prepare-axpy) [ XAXPY ] dip ;
M: VECTOR n*V! M: VECTOR n*V!
(prepare-scal) [ XSCAL execute ] dip ; (prepare-scal) [ XSCAL ] dip ;
;FUNCTOR ;FUNCTOR
@ -207,13 +207,13 @@ COMPLEX>ARG DEFINES ${TYPE}-complex>arg
WHERE WHERE
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence ) : <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
1 shift <DIRECT-ARRAY> execute <complex-sequence> ; 1 shift <DIRECT-ARRAY> <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence ) : >COMPLEX-ARRAY ( sequence -- sequence )
<complex-components> >ARRAY execute ; <complex-components> >ARRAY ;
: COMPLEX>ARG ( complex -- alien ) : COMPLEX>ARG ( complex -- alien )
>rect 2array >ARRAY execute underlying>> ; >rect 2array >ARRAY underlying>> ;
: ARG>COMPLEX ( alien -- complex ) : ARG>COMPLEX ( alien -- complex )
2 <DIRECT-ARRAY> execute first2 rect> ; 2 <DIRECT-ARRAY> first2 rect> ;
;FUNCTOR ;FUNCTOR
@ -234,22 +234,22 @@ WHERE
M: VECTOR V. M: VECTOR V.
(prepare-dot) TYPE <c-object> (prepare-dot) TYPE <c-object>
[ XDOTU_SUB execute ] keep [ XDOTU_SUB ] keep
ARG>TYPE execute ; ARG>TYPE ;
M: VECTOR V.conj M: VECTOR V.conj
(prepare-dot) TYPE <c-object> (prepare-dot) TYPE <c-object>
[ XDOTC_SUB execute ] keep [ XDOTC_SUB ] keep
ARG>TYPE execute ; ARG>TYPE ;
M: VECTOR Vnorm M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 execute ; (prepare-nrm2) XXNRM2 ;
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XXASUM execute ; (prepare-nrm2) XXASUM ;
M: VECTOR n*V+V! M: VECTOR n*V+V!
[ TYPE>ARG execute ] 2dip [ TYPE>ARG ] 2dip
(prepare-axpy) [ XAXPY execute ] dip ; (prepare-axpy) [ XAXPY ] dip ;
M: VECTOR n*V! M: VECTOR n*V!
[ TYPE>ARG execute ] dip [ TYPE>ARG ] dip
(prepare-scal) [ XSCAL execute ] dip ; (prepare-scal) [ XSCAL ] dip ;
;FUNCTOR ;FUNCTOR

View File

@ -0,0 +1 @@
Daniel Ehrenberg

View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax strings byte-arrays io.encodings.string ;
IN: quoted-printable
ABOUT: "quoted-printable"
ARTICLE: "quoted-printable" "Quoted printable encoding"
"The " { $vocab-link "quoted-printable" } " vocabulary implements RFC 2045 part 6.7, providing words for reading and generating quotable printed text."
{ $subsection >quoted }
{ $subsection >quoted-lines }
{ $subsection quoted> } ;
HELP: >quoted
{ $values { "byte-array" byte-array } { "string" string } }
{ $description "Encodes a byte array as quoted printable, on a single line." }
{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word." } ;
HELP: >quoted-lines
{ $values { "byte-array" byte-array } { "string" string } }
{ $description "Encodes a byte array as quoted printable, with soft line breaks inserted so the output lines are no longer than 76 characters." }
{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word with a specific encoding." } ;
HELP: quoted>
{ $values { "string" string } { "byte-array" byte-array } }
{ $description "Decodes a quoted printable string into an array of the bytes represented." }
{ $warning "When decoding something in quoted printable form and using it as a string, be sure to use the " { $link decode } " word rather than simply converting the byte array to a string." } ;

View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test quoted-printable multiline io.encodings.string
sequences io.encodings.8-bit splitting kernel ;
IN: quoted-printable.tests
[ <" José was the
person who knew how to write the letters:
ő and ü
and we didn't know hów tö do thât"> ]
[ <" Jos=E9 was the
person who knew how to write the letters:
=F5 and =FC=20
and w=
e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test
[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ]
[ <" José was the
person who knew how to write the letters:
ő and ü
and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test
: message ( -- str )
55 [ "hello" ] replicate concat ;
[ f ] [ message >quoted "=\r\n" swap subseq? ] unit-test
[ 1 ] [ message >quoted string-lines length ] unit-test
[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test
[ 4 ] [ message >quoted-lines string-lines length ] unit-test
[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test

View File

@ -0,0 +1,62 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sequences strings kernel io.encodings.string
math.order ascii math io io.encodings.utf8 io.streams.string
combinators.short-circuit math.parser arrays ;
IN: quoted-printable
! This implements RFC 2045 section 6.7
<PRIVATE
: assure-small ( ch -- ch )
dup 256 <
[ "Cannot quote a character greater than 255" throw ] unless ;
: printable? ( ch -- ? )
{
[ CHAR: \s CHAR: < between? ]
[ CHAR: > CHAR: ~ between? ]
[ CHAR: \t = ]
} 1|| ;
: char>quoted ( ch -- str )
dup printable? [ 1string ] [
assure-small >hex >upper
2 CHAR: 0 pad-left
CHAR: = prefix
] if ;
: take-some ( seqs -- seqs seq )
0 over [ length + dup 76 >= ] find drop nip
[ 1- cut-slice swap ] [ f swap ] if* concat ;
: divide-lines ( strings -- strings )
[ dup ] [ take-some ] [ ] produce nip ;
PRIVATE>
: >quoted ( byte-array -- string )
[ char>quoted ] { } map-as concat "" like ;
: >quoted-lines ( byte-array -- string )
[ char>quoted ] { } map-as
divide-lines "=\r\n" join ;
<PRIVATE
: read-char ( byte -- ch )
dup CHAR: = = [
drop read1 dup CHAR: \n =
[ drop read1 read-char ]
[ read1 2array hex> ] if
] when ;
: read-quoted ( -- bytes )
[ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ;
PRIVATE>
: quoted> ( string -- byte-array )
! Input should already be normalized to make \r\n into \n
[ read-quoted ] with-string-reader ;

View File

@ -0,0 +1 @@
Quoted printable encoding/decoding

View File

@ -0,0 +1,2 @@
parsing
web

View File

@ -4,7 +4,7 @@ USING: combinators kernel prettyprint io io.timeouts sequences
namespaces io.sockets io.sockets.secure continuations calendar namespaces io.sockets io.sockets.secure continuations calendar
io.encodings.ascii io.streams.duplex destructors locals io.encodings.ascii io.streams.duplex destructors locals
concurrency.promises threads accessors smtp.private concurrency.promises threads accessors smtp.private
io.sockets.secure.unix.debug ; io.sockets.secure.unix.debug io.crlf ;
IN: smtp.server IN: smtp.server
! Mock SMTP server for testing purposes. ! Mock SMTP server for testing purposes.

View File

@ -6,7 +6,7 @@ io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
io.encodings.ascii kernel logging sequences combinators io.encodings.ascii kernel logging sequences combinators
splitting assocs strings math.order math.parser random system splitting assocs strings math.order math.parser random system
calendar summary calendar.format accessors sets hashtables calendar summary calendar.format accessors sets hashtables
base64 debugger classes prettyprint ; base64 debugger classes prettyprint io.crlf ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
@ -50,12 +50,6 @@ TUPLE: email
<PRIVATE <PRIVATE
: crlf ( -- ) "\r\n" write ;
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: command ( string -- ) write crlf flush ; : command ( string -- ) write crlf flush ;
\ command DEBUG add-input-logging \ command DEBUG add-input-logging

View File

@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
: >A ( seq -- specialized-array ) A new clone-like ; inline : >A ( seq -- specialized-array ) A new clone-like ; inline
M: A like drop dup A instance? [ >A execute ] unless ; M: A like drop dup A instance? [ >A ] unless ;
M: A new-sequence drop (A) execute ; M: A new-sequence drop (A) ;
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
@ -70,7 +70,7 @@ M: A >pprint-sequence ;
M: A pprint* pprint-object ; M: A pprint* pprint-object ;
: A{ \ } [ >A execute ] parse-literal ; parsing : A{ \ } [ >A ] parse-literal ; parsing
INSTANCE: A sequence INSTANCE: A sequence

View File

@ -18,16 +18,16 @@ WHERE
TUPLE: V { underlying A } { length array-capacity } ; TUPLE: V { underlying A } { length array-capacity } ;
: <V> ( capacity -- vector ) <A> execute 0 V boa ; inline : <V> ( capacity -- vector ) <A> 0 V boa ; inline
M: V like M: V like
drop dup V instance? [ drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V execute ] if dup A instance? [ dup length V boa ] [ >V ] if
] unless ; ] unless ;
M: V new-sequence drop [ <A> execute ] [ >fixnum ] bi V boa ; M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
M: A new-resizable drop <V> execute ; M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
@ -39,7 +39,7 @@ M: V >pprint-sequence ;
M: V pprint* pprint-object ; M: V pprint* pprint-object ;
: V{ \ } [ >V execute ] parse-literal ; parsing : V{ \ } [ >V ] parse-literal ; parsing
INSTANCE: V growable INSTANCE: V growable

View File

@ -19,10 +19,6 @@ IN: xml.utilities
: first-child-tag ( tag -- tag ) : first-child-tag ( tag -- tag )
children>> [ tag? ] find nip ; children>> [ tag? ] find nip ;
! * 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 -- ? ) : tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ; dup tag? [ names-match? ] [ 2drop f ] if ;
@ -36,8 +32,6 @@ IN: xml.utilities
tags@ '[ _ swap tag-named? ] deep-filter ; tags@ '[ _ swap tag-named? ] deep-filter ;
: tag-named ( tag name/string -- matching-tag ) : 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? ] with find nip ; assure-name swap [ tag-named? ] with find nip ;
: tags-named ( tag name/string -- tags-seq ) : tags-named ( tag name/string -- tags-seq )
@ -58,7 +52,7 @@ IN: xml.utilities
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] deep-filter ; tags@ '[ _ _ tag-with-attr? ] deep-filter ;
: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) : get-id ( tag id -- elem )
"id" deep-tag-with-attr ; "id" deep-tag-with-attr ;
: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags ) : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )

View File

@ -233,16 +233,11 @@
;; Default is word constituent ;; Default is word constituent
(dotimes (i 256) (dotimes (i 256)
(modify-syntax-entry i "w" table)) (modify-syntax-entry i "w" table))
;; Whitespace (TAB is not whitespace) ;; Whitespace (TAB is not whitespace)
(modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\f " " table)
(modify-syntax-entry ?\r " " table) (modify-syntax-entry ?\r " " table)
(modify-syntax-entry ?\ " " table) (modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table) (modify-syntax-entry ?\n " " table)
;; Char quote
(modify-syntax-entry ?\\ "/" table)
table)) table))
(defconst fuel-syntax--syntactic-keywords (defconst fuel-syntax--syntactic-keywords
@ -254,9 +249,9 @@
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b")) (" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b")) (" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings ;; Strings
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\)" ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (4 "\"")) (3 "\"") (5 "\""))
("\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\|$\\)" (1 "\"") (2 "\"")) ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b")) ("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b")) ("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs ;; Multiline constructs