unions and complements over tuples are still not supported. Also,
predicate subclasses of concrete tuple classes are not supported either.
-The seq-each and seq-map words have been renamed to each and map, and
-now work with lists. The each and map words in the lists vocabulary have
-been removed; use the new generic equivalents instead.
-
The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
data could fill up the buffer and cause a denial-of-service attack.
G: foo [ dup ] [ type ] ;
+The seq-each and seq-map words have been renamed to each and map, and
+now work with lists. The each and map words in the lists vocabulary have
+been removed; use the new generic equivalents instead.
+
Added two new types of 'virtual' sequences: a range sequence containing
a range of integers, and a slice sequence containing a subsequence of
another sequence.
+Some string words were made generic, and now work with all sequences:
+
+Old word: New word:
+--------- ---------
+string-head head
+string-head? head?
+?string-head ?head
+string-tail tail
+string-tail? tail?
+?string-tail ?tail
+substring subseq
+cat2 append
+cat3 append3
+
Factor 0.74:
------------
- [ over ] generics no-method\r
- investigate if COPYING_GEN needs a fix\r
- simplifier:\r
- - dead loads not optimized out\r
- kill tag-fixnum/untag-fixnum\r
-- \ foo where foo is parsing is not printed readably\r
+ - kill replace after a peek\r
+ - merge inc-d's across VOPs that don't touch the stack\r
- faster layout\r
- tiled window manager\r
- c primitive arrays: or just specialized arrays\r
- if external factor is down, don't add tons of random shit to the \r
dictionary\r
- SDL_Rect** type\r
-- get all-tests to run with -no-compile\r
- fix i/o on generic x86/ppc unix\r
- alien primitives need a more general input type\r
- 2map slow with lists\r
- nappend: instead of using push, enlarge the sequence with set-length\r
then add set the elements with set-nth\r
- faster sequence operations\r
-- generic some? all? memq? all=? index? subseq?\r
+- generic some? all? memq? all=?\r
- index and index* are very slow with lists\r
- unsafe-sbuf>string\r
-- generic subseq\r
- code walker & exceptions\r
- if two tasks write to a unix stream, the buffer can overflow\r
- rename prettyprint to pprint\r
- type inference fails with some assembler words;\r
displaced, register and other predicates need to inherit from list\r
not cons, and need stronger branch partial eval\r
-- redo partial eval\r
- optimize away arithmetic dispatch\r
- dataflow optimizer needs eq not =\r
- the invalid recursion form case needs to be fixed, for inlines too\r
+ sequences\r
\r
- list map, subset: not tail recursive\r
-- phase out sbuf-append, index-of, substring\r
+- phase out sbuf-append\r
\r
+ kernel:\r
\r
: c-type ( name -- type )
dup c-types get hash [ ] [
- "No such C type: " swap cat2 throw f
+ "No such C type: " swap append throw f
] ?ifte ;
: c-size ( name -- size )
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
- "set-" swap cat2 create-in >r
+ "set-" swap append create-in >r
[ "setter" get ] bind cons r> swap define-compound ;
: define-field ( offset type name -- offset )
>r c-type dup >r [ "align" get ] bind align r> r>
- "struct-name" get swap "-" swap cat3
+ "struct-name" get swap "-" swap append3
( offset type name -- )
3dup define-getter 3dup define-setter
drop [ "width" get ] bind + ;
"/library/collections/strings.factor"
"/library/collections/sbuf.factor"
"/library/collections/sequences-epilogue.factor"
- "/library/collections/vectors-epilogue.factor"
"/library/collections/hashtables.factor"
"/library/collections/namespaces.factor"
+ "/library/collections/slicing.factor"
+ "/library/collections/vectors-epilogue.factor"
"/library/collections/strings-epilogue.factor"
"/library/math/matrices.factor"
"/library/words.factor"
( Strings )
: align-string ( n str -- )
- tuck length - CHAR: \0 fill cat2 ;
+ tuck length - CHAR: \0 fill append ;
: emit-chars ( str -- )
>list "big-endian" get [ reverse ] unless
string-type >header emit
dup length emit-fixnum
dup hashcode emit-fixnum
- "\0" cat2 pack-string
+ "\0" append pack-string
align-here ;
M: string ' ( string -- pointer )
[ "cons" "lists" [ [ object object ] [ cons ] ] ]
[ "<vector>" "vectors" [ [ integer ] [ vector ] ] ]
[ "string-compare" "strings" [ [ string string ] [ integer ] ] ]
- [ "index-of*" "strings" [ [ integer string object ] [ integer ] ] ]
- [ "substring" "strings" [ [ integer integer string ] [ string ] ] ]
+ [ "rehash-string" "strings" [ [ string ] [ ] ] ]
[ "<sbuf>" "strings" [ [ integer ] [ sbuf ] ] ]
+ [ "sbuf>string" "strings" [ [ sbuf ] [ string ] ] ]
[ "arithmetic-type" "math-internals" [ [ object object ] [ object object fixnum ] ] ]
[ ">fixnum" "math" [ [ number ] [ fixnum ] ] ]
[ ">bignum" "math" [ [ number ] [ bignum ] ] ]
: cli-var-param ( name value -- ) swap ":" split set-path ;
-: cli-bool-param ( name -- ) "no-" ?string-head not swap set ;
+: cli-bool-param ( name -- ) "no-" ?head not swap set ;
: cli-param ( param -- )
#! Handle a command-line argument starting with '-' by
#! consumed, returns f. Otherwise returns the argument.
#! Parameters that start with + are runtime parameters.
dup empty? [
- "-" ?string-head [ cli-param f ] when
- dup [ "+" ?string-head [ drop f ] when ] when
+ "-" ?head [ cli-param f ] when
+ dup [ "+" ?head [ drop f ] when ] when
] unless ;
: parse-switches ( args -- args )
: project-with ( elt n quot -- list )
swap [ with rot ] project 2nip ; inline
-: head ( list n -- list )
+M: general-list head ( n list -- list )
#! Return the first n elements of the list.
- dup 0 > [ >r uncons r> 1 - head cons ] [ 2drop f ] ifte ;
+ over 0 > [
+ unswons >r >r 1 - r> head r> swons
+ ] [
+ 2drop f
+ ] ifte ;
-: tail ( list n -- tail )
+M: general-list tail ( n list -- tail )
#! Return the rest of the list, from the nth index onward.
- [ cdr ] times ;
+ swap [ cdr ] times ;
M: cons nth ( n list -- element )
over 0 = [ nip car ] [ >r 1 - r> cdr nth ] ifte ;
growable-check 2dup ensure underlying
>r >r >fixnum r> r> set-char-slot ;
-M: sbuf >string
- [ 0 swap length ] keep underlying substring ;
+M: sbuf >string sbuf>string ;
swap [ swap 2nmap ] immutable ;
! Operations
-: index* ( obj i seq -- n )
+: index* ( obj seq i -- n )
#! The index of the object in the sequence, starting from i.
- 2dup length >= [
+ over length over <= [
3drop -1
] [
- 3dup nth = [ drop nip ] [ >r 1 + r> index* ] ifte
+ 3dup swap nth = [ 2nip ] [ 1 + index* ] ifte
] ifte ;
: index ( obj seq -- n )
#! The index of the object in the sequence.
- 0 swap index* ;
+ 0 index* ;
M: object contains? ( obj seq -- ? ) index -1 > ;
] ifte
] ifte ;
-! A repeated sequence is the same element n times.
-TUPLE: repeated length object ;
-M: repeated length repeated-length ;
-M: repeated nth nip repeated-object ;
-
-! A range of integers
-TUPLE: range from to step ;
-
-C: range ( from to -- range )
- >r 2dup > -1 1 ? r>
- [ set-range-step ] keep
- [ set-range-to ] keep
- [ set-range-from ] keep ;
-
-M: range length ( range -- n )
- dup range-to swap range-from - abs ;
-
-M: range nth ( n range -- n )
- [ range-step * ] keep range-from + ;
-
-! A slice of another sequence.
-TUPLE: slice seq ;
-
-C: slice ( from to seq -- )
- [ set-slice-seq ] keep
- [ >r <range> r> set-delegate ] keep ;
-
-M: slice nth ( n slice -- obj )
- [ delegate nth ] keep slice-seq nth ;
-
-M: slice set-nth ( obj n slice -- )
- [ delegate nth ] keep slice-seq set-nth ;
-
-: tail-slice ( n seq -- slice )
- [ length [ swap - ] keep ] keep <slice> ;
-
IN: kernel
: depth ( -- n )
GENERIC: nth ( n sequence -- obj )
GENERIC: set-nth ( value n sequence -- obj )
GENERIC: thaw ( seq -- mutable-seq )
+GENERIC: like ( seq seq -- seq )
GENERIC: freeze ( new orig -- new )
GENERIC: reverse ( seq -- seq )
GENERIC: peek ( seq -- elt )
GENERIC: contains? ( elt seq -- ? )
+GENERIC: head ( n seq -- seq )
+GENERIC: tail ( n seq -- seq )
G: each ( seq quot -- | quot: elt -- )
[ over ] [ type ] ; inline
DEFER: <range>
DEFER: append ! remove this when sort is moved from lists to sequences
+DEFER: subseq
! Some low-level code used by vectors and string buffers.
IN: kernel-internals
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: strings
-USING: generic kernel lists math namespaces sequences strings ;
+USING: generic kernel kernel-internals lists math namespaces
+sequences strings ;
: sbuf-append ( ch/str sbuf -- )
over string? [ swap nappend ] [ push ] ifte ;
-: cat2 ( "a" "b" -- "ab" )
- swap
- 80 <sbuf>
- [ sbuf-append ] keep
- [ sbuf-append ] keep
- >string ;
-
-: cat3 ( "a" "b" "c" -- "abc" )
- >r >r >r 80 <sbuf>
- r> over sbuf-append
- r> over sbuf-append
- r> over sbuf-append >string ;
-
: fill ( count char -- string ) <repeated> >string ;
: pad ( string count char -- string )
r> fill swap append
] ifte ;
-: split-next ( index string split -- next )
- 3dup index-of* dup -1 = [
- >r drop string-tail , r> ( end of string )
- ] [
- swap length dupd + >r swap substring , r>
- ] ifte ;
-
-: (split) ( index string split -- )
- 2dup >r >r split-next dup -1 = [
- drop r> drop r> drop
- ] [
- r> r> (split)
- ] ifte ;
-
-: split ( string split -- list )
- #! Split the string at each occurrence of split, and push a
- #! list of the pieces.
- [ 0 -rot (split) ] make-list ;
-
-: split-n-advance substring , >r tuck + swap r> ;
-: split-n-finish nip dup length swap substring , ;
-
-: (split-n) ( start n str -- )
- 3dup >r dupd + r> 2dup length < [
- split-n-advance (split-n)
- ] [
- split-n-finish 3drop
- ] ifte ;
-
-: split-n ( n str -- list )
- #! Split a string into n-character chunks.
- [ 0 -rot (split-n) ] make-list ;
-
: ch>string ( ch -- str ) 1 <sbuf> [ push ] keep >string ;
-: >sbuf ( seq -- sbuf ) 0 <sbuf> [ swap nappend ] keep ;
+: >sbuf ( seq -- sbuf ) dup length <sbuf> [ swap nappend ] keep ;
-M: object >string >sbuf >string ;
+M: object >string >sbuf underlying dup rehash-string ;
M: string thaw >sbuf ;
M: string freeze drop >string ;
+M: string like ( seq sbuf -- sbuf ) drop >string ;
M: sbuf clone ( sbuf -- sbuf )
[ length <sbuf> dup ] keep nappend ;
+
+M: sbuf like ( seq sbuf -- sbuf ) drop >sbuf ;
! Returns if the first string lexicographically follows str2
string-compare 0 > ;
-: length< ( seq seq -- ? )
- #! Compare sequence lengths.
- swap length swap length < ;
-
-: index-of ( string substring -- index )
- 0 -rot index-of* ;
-
-: string-contains? ( substr str -- ? )
- swap index-of -1 = not ;
-
-: string-head ( index str -- str )
- #! Returns a new string, from the beginning of the string
- #! until the given index.
- 0 -rot substring ;
-
-: string-tail ( index str -- str )
- #! Returns a new string, from the given index until the end
- #! of the string.
- [ length ] keep substring ;
-
-: string/ ( str index -- str str )
- #! Returns 2 strings, that when concatenated yield the
- #! original string.
- [ swap string-head ] 2keep swap string-tail ;
-
-: string// ( str index -- str str )
- #! Returns 2 strings, that when concatenated yield the
- #! original string, without the character at the given
- #! index.
- [ swap string-head ] 2keep 1 + swap string-tail ;
-
-: string-head? ( str begin -- ? )
- 2dup length< [
- 2drop f
- ] [
- dup length rot string-head =
- ] ifte ;
-
-: ?string-head ( str begin -- str ? )
- 2dup string-head? [
- length swap string-tail t
- ] [
- drop f
- ] ifte ;
-
-: string-tail? ( str end -- ? )
- 2dup length< [
- 2drop f
- ] [
- dup length pick length swap - rot string-tail =
- ] ifte ;
-
-: ?string-tail ( str end -- str ? )
- 2dup string-tail? [
- length swap [ length swap - ] keep string-head t
- ] [
- drop f
- ] ifte ;
-
-: split1 ( string split -- before after )
- 2dup index-of dup -1 = [
- 2drop f
- ] [
- [ swap length + over string-tail ] keep
- rot string-head swap
- ] ifte ;
-
! Characters
-PREDICATE: integer blank " \t\n\r" string-contains? ;
+PREDICATE: integer blank " \t\n\r" contains? ;
PREDICATE: integer letter CHAR: a CHAR: z between? ;
PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without
#! escaping?
- dup printable? swap "\"\\" string-contains? not and ;
+ dup printable? swap "\"\\" contains? not and ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
dup letter?
over LETTER? or
over digit? or
- swap "/_?." string-contains? or ;
+ swap "/_?." contains? or ;
M: vector clone ( vector -- vector )
>vector ;
-: vector-project ( n quot -- vector )
- #! Execute the quotation n times, passing the loop counter
- #! the quotation as it ranges from 0..n-1. Collect results
- #! in a new vector.
- >r 0 swap <range> >vector r> map ; inline
-
: zero-vector ( n -- vector )
- [ drop 0 ] vector-project ;
-
-: vector-tail ( n vector -- list )
- #! Return a new list with all elements from the nth
- #! index upwards.
- 2dup length swap - [
- pick + over nth
- ] project 2nip ;
-
-: vector-tail* ( n vector -- list )
- #! Unlike vector-tail, n is an index from the end of the
- #! vector. For example, if n=1, this returns a vector of
- #! one element.
- [ length swap - ] keep vector-tail ;
+ 0 <repeated> >vector ;
M: general-list thaw >vector ;
M: general-list freeze drop >list ;
+M: general-list like drop >list ;
+
+M: vector like drop >vector ;
! A simple single-dispatch generic word system.
: predicate-word ( word -- word )
- word-name "?" cat2 create-in
+ word-name "?" append create-in
dup t "inline" set-word-prop ;
! Terminology:
: id>url ( id -- string )
#! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML.
- url-encode "?id=" swap cat2 ;
+ url-encode "?id=" swap append ;
DEFER: show-final
DEFER: show
] ifte ;
: serve-directory ( filename -- )
- "/" ?string-tail [
+ "/" ?tail [
dup "/index.html" append dup exists? [
serve-file
] [
! <a href= a> "Click me" write </a>
!
! (url -- )
-! <a href= "http://" swap cat2 a> "click" write </a>
+! <a href= "http://" swap append a> "click" write </a>
!
! (url -- )
! <a href= [ "http://" , , ] make-string a> "click" write </a>
: def-for-html-word-<foo> ( name -- name quot )
#! Return the name and code for the <foo> patterned
#! word.
- "<" swap ">" cat3 dup [ write ] cons ;
+ "<" swap ">" append3 dup [ write ] cons ;
: def-for-html-word-<foo ( name -- name quot )
#! Return the name and code for the <foo patterned
#! word.
- "<" swap cat2 dup [ write <namespace> >n ] cons ;
+ "<" swap append dup [ write <namespace> >n ] cons ;
: def-for-html-word-foo> ( name -- name quot )
#! Return the name and code for the foo> patterned
#! word.
- ">" cat2 [
+ ">" append [
store-prev-attribute write-attributes n> drop ">" write
] ;
: def-for-html-word-foo/> ( name -- name quot )
#! Return the name and code for the foo/> patterned
#! word.
- "/>" cat2 [
+ "/>" append [
store-prev-attribute write-attributes n> drop ">" write
] ;
def-for-html-word-foo/> create-word ;
: define-attribute-word ( name -- )
- "html" swap dup "=" cat2 swap
+ "html" swap dup "=" append swap
[ store-prev-attribute ] cons reverse
[ "current-attribute" set ] append create-word ;
#! The file responder needs relative links not absolute
#! links.
"doc-root" get [
- ?string-head [ "/" ?string-head drop ] when
- ] when* "/" ?string-tail drop ;
+ ?head [ "/" ?head drop ] when
+ ] when* "/" ?tail drop ;
: file-link-href ( path -- href )
[ "/" , resolve-file-link url-encode , ] make-string ;
: icon-tag ( string style quot -- )
over "icon" swap assoc dup [
- <img src= "/responder/resource/" swap cat2 img/>
+ <img src= "/responder/resource/" swap append img/>
#! Ignore the quotation, since no further style
#! can be applied
3drop
":" split1 [ parse-number ] [ 80 ] ifte* ;
: parse-url ( url -- host resource )
- "http://" ?string-head [
+ "http://" ?head [
"URL must begin with http://" throw
] unless
"/" split1 [ "/" swap append ] [ "/" ] ifte* ;
: parse-response ( line -- code )
- "HTTP/" ?string-head [ " " split1 nip ] when
+ "HTTP/" ?head [ " " split1 nip ] when
" " split1 drop parse-number ;
: read-response ( -- code header )
2dup length 2 - >= [
2drop
] [
- >r 1 + dup 2 + r> substring catch-hex> [ , ] when*
+ >r 1 + dup 2 + r> subseq catch-hex> [ , ] when*
] ifte ;
: url-decode-% ( index str -- index str )
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
USING: errors kernel lists namespaces
-stdio streams strings threads http ;
+stdio streams strings threads http sequences ;
: (url>path) ( uri -- path )
- url-decode "http://" ?string-head [
+ url-decode "http://" ?head [
"/" split1 dup "" ? nip
] when ;
: url>path ( uri -- path )
"?" split1 dup [
- >r (url>path) "?" r> cat3
+ >r (url>path) "?" r> append3
] [
drop (url>path)
] ifte ;
: secure-path ( path -- path )
- ".." over string-contains? [ drop f ] when ;
+ ".." over subseq? [ drop f ] when ;
: request-method ( cmd -- method )
[
"HTTP/1.0 " write print print-header ;
: error-body ( error -- body )
- "<html><body><h1>" swap "</h1></body></html>" cat3 print ;
+ "<html><body><h1>" swap "</h1></body></html>" append3 print ;
: error-head ( error -- )
dup log-error
default-responder call-responder ;
: log-responder ( url -- )
- "Calling responder " swap cat2 log ;
+ "Calling responder " swap append log ;
: trim-/ ( url -- url )
#! Trim a leading /, if there is one.
- "/" ?string-head drop ;
+ "/" ?head drop ;
: serve-explicit-responder ( method url -- )
"/" split1 dup [
swap get-responder call-responder
] [
! Just a responder name by itself
- drop "request" get "/" cat2 redirect drop
+ drop "request" get "/" append redirect drop
] ifte ;
: serve-responder ( method url -- )
#! Responder URLs come in two forms:
#! /foo/bar... - default-responder used
#! /responder/foo/bar - responder foo, argument bar
- dup log-responder trim-/ "responder/" ?string-head [
+ dup log-responder trim-/ "responder/" ?head [
serve-explicit-responder
] [
serve-default-responder
0 swap [ length max ] each ;
: computed-value-vector ( n -- vector )
- [ drop object <computed> ] vector-project ;
+ [ drop object <computed> ] project >vector ;
: add-inputs ( count stack -- stack )
#! Add this many inputs to the given stack.
#! Turn a list of same-length vectors into a vector of lists.
dup car length [
over [ nth ] map-with
- ] vector-project nip ;
+ ] project >vector nip ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
: in-d-node ( inputs) >r f f r> f f f f ;
: out-d-node ( outputs) >r f f f r> f f f ;
-: d-tail ( n -- list ) meta-d get vector-tail* ;
-: r-tail ( n -- list ) meta-r get vector-tail* ;
+: d-tail ( n -- list ) meta-d get tail* >list ;
+: r-tail ( n -- list ) meta-r get tail* >list ;
NODE: #label
: #label ( label -- node ) param-node <#label> ;
: ensure-types ( typelist stack -- )
dup length pick length - dup 0 < [
- swap >r neg tail 0 r>
+ swap >r neg swap tail 0 r>
] [
swap
] ifte (ensure-types) ;
: required-inputs ( typelist stack -- values )
>r dup length r> length - dup 0 > [
- head [ <computed> ] map
+ swap head [ <computed> ] map
] [
2drop f
] ifte ;
sequences words ;
: literal-inputs? ( in stack -- )
- tail-slice dup >list [ safe-literal? ] all? [
+ tail-slice* dup >list [ safe-literal? ] all? [
length #drop node, t
] [
drop f
] ifte ;
: literal-inputs ( out stack -- )
- tail-slice [ literal-value ] nmap ;
+ tail-slice* [ literal-value ] nmap ;
: literal-outputs ( out stack -- )
- tail-slice dup [ recursive-state get <literal> ] nmap
+ tail-slice* dup [ recursive-state get <literal> ] nmap
length #push node, ;
: partial-eval? ( word -- ? )
! See http://factor.sf.net/license.txt for BSD license.
IN: ansi
USING: lists kernel namespaces stdio streams strings
-presentation generic ;
+presentation generic sequences ;
! <ansi-stream> raps the given stream in an ANSI stream. ANSI
! streams support the following character attributes:
: fg ( color -- code )
#! Set foreground color.
- "\e[3" swap "m" cat3 ; inline
+ "\e[3" swap "m" append3 ; inline
: bg ( color -- code )
#! Set foreground color.
- "\e[4" swap "m" cat3 ; inline
+ "\e[4" swap "m" append3 ; inline
: ansi-attrs ( style -- )
"bold" over assoc [ bold , ] when
: file-icon. directory? dir-icon file-icon ? write-icon ;
: file-link. ( dir name -- )
- tuck "/" swap cat3 dup "file" swons swap
+ tuck "/" swap append3 dup "file" swons swap
unparse file-actions <actions> "actions" swons
2list write-attr ;
: file. ( dir name -- )
#! If "doc-root" set, create links relative to it.
- 2dup "/" swap cat3 file-icon. bl file-link. terpri ;
+ 2dup "/" swap append3 file-icon. bl file-link. terpri ;
: directory. ( dir -- )
#! If "doc-root" set, create links relative to it.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: streams
-USING: kernel namespaces stdio strings unparser ;
+USING: kernel namespaces stdio sequences strings unparser ;
! A simple logging framework.
SYMBOL: log-stream
print flush
] ifte* ;
-: log-error ( error -- ) "Error: " swap cat2 log ;
+: log-error ( error -- ) "Error: " swap append log ;
: log-client ( client-stream -- )
[
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: files
-USING: kernel strings ;
+USING: kernel strings sequences ;
! We need this early during bootstrap.
: path+ ( path path -- path )
#! Combine two paths. This will be implemented later.
- "/" swap cat3 ;
+ "/" swap append3 ;
IN: stdio
DEFER: stdio
: base> ( str base -- num )
#! Convert a string to an integer. Throw an error if
#! conversion fails.
- swap "-" ?string-head [ (base>) neg ] [ (base>) ] ifte ;
+ swap "-" ?head [ (base>) neg ] [ (base>) ] ifte ;
GENERIC: str>number ( str -- num )
M: string str>number 10 base> ;
-PREDICATE: string potential-ratio "/" swap string-contains? ;
+PREDICATE: string potential-ratio CHAR: / swap contains? ;
M: potential-ratio str>number ( str -- num )
- dup CHAR: / index-of string// swap 10 base> swap 10 base> / ;
+ dup CHAR: / swap index swap cut*
+ swap 10 base> swap 10 base> / ;
-PREDICATE: string potential-float "." swap string-contains? ;
+PREDICATE: string potential-float CHAR: . swap contains? ;
M: potential-float str>number ( str -- num )
str>float ;
#! resource:. This allows words that operate on source
#! files, like "jedit", to use a different resource path
#! at run time than was used at parse time.
- "resource:" over cat2 swap <resource-stream> parse-stream ;
+ "resource:" over append swap <resource-stream> parse-stream ;
: run-resource ( file -- )
parse-resource call ;
: \
#! Parsed as a piece of code that pushes a word on the stack
#! \ foo ==> [ foo ] car
- scan-word unit swons \ car swons ; parsing
+ scan-word dup word? [
+ unit swons \ car swons
+ ] [
+ swons
+ ] ifte ; parsing
! Vocabularies
: PRIMITIVE:
! Comments
: (
#! Stack comment.
- ")" until parsed-stack-effect ; parsing
+ CHAR: ) until parsed-stack-effect ; parsing
: !
#! EOL comment.
: scan ( -- token )
"col" get "line" get dup >r (scan) dup "col" set
- 2dup = [ r> 3drop f ] [ r> substring ] ifte ;
+ 2dup = [ r> 3drop f ] [ r> subseq ] ifte ;
: save-location ( word -- )
#! Remember where this word was defined.
! Used by parsing words
: ch-search ( ch -- index )
- "col" get "line" get rot index-of* ;
+ "line" get "col" get index* ;
: (until) ( index -- str )
- "col" get swap dup 1 + "col" set "line" get substring ;
+ "col" get swap dup 1 + "col" set "line" get subseq ;
: until ( ch -- str )
ch-search (until) ;
: (until-eol) ( -- index )
- "\n" ch-search dup -1 = [ drop "line" get length ] when ;
+ CHAR: \n ch-search dup -1 = [ drop "line" get length ] when ;
: until-eol ( -- str )
#! This is just a hack to get "eval" to work with multiline
: next-escape ( n str -- ch n )
2dup nth CHAR: u = [
- swap 1 + dup 4 + [ rot substring hex> ] keep
+ swap 1 + dup 4 + [ rot subseq hex> ] keep
] [
over 1 + >r nth escape r>
] ifte ;
: documentation+ ( word str -- )
over "documentation" word-prop [
- swap "\n" swap cat3
+ swap "\n" swap append3
] when*
"documentation" set-word-prop ;
: \? ( list -- ? )
#! Is the head of the list a [ foo ] car?
dup car dup cons? [
- cdr [ drop f ] [ cdr car \ car = ] ifte
+ dup car word? [
+ cdr [ drop f ] [ cdr car \ car = ] ifte
+ ] [
+ 2drop f
+ ] ifte
] [
2drop f
] ifte ;
[
dup \? [
\ \ word. bl
- uncons >r car prettyprint* bl
+ uncons >r car word. bl
r> cdr prettyprint-elements
] [
uncons >r prettyprint* bl
] with-scope ;
: vocab-link ( vocab -- link )
- "vocabularies'" swap cat2 ;
+ "vocabularies'" swap append ;
: . ( obj -- )
[
: documentation. ( indent word -- indent )
"documentation" word-prop [
"\n" split [
- "#!" swap cat2 comment.
+ "#!" swap append comment.
dup prettyprint-newline
] each
] when* ;
: fix-float ( str -- str )
#! This is terrible. Will go away when we do our own float
#! output.
- "." over string-contains? [ ".0" cat2 ] unless ;
+ CHAR: . over contains? [ ".0" append ] unless ;
M: float unparse ( float -- str )
(unparse-float) fix-float ;
] assoc ;
: ch>unicode-escape ( ch -- esc )
- >hex 4 CHAR: 0 pad "\\u" swap cat2 ;
+ >hex 4 CHAR: 0 pad "\\u" swap append ;
: unparse-ch ( ch -- ch/str )
dup quotable? [
: string-step ( n str -- )
2dup length > [
dup [ "123" , , "456" , , "789" , ] make-string
- dup dup length 2 /i 0 swap rot substring
- swap dup length 2 /i 1 + 1 swap rot substring append
+ dup dup length 2 /i 0 swap rot subseq
+ swap dup length 2 /i 1 + 1 swap rot subseq append
string-step
] [
2drop
] unit-test
[ "Hello, crazy" ] [
- "editor" get [ caret get line-text get string-head ] bind
+ "editor" get [ caret get line-text get head ] bind
] unit-test
[ 0 ]
[ [ ] ] [ 0 count ] unit-test
[ [ 0 1 2 3 ] ] [ 4 count ] unit-test
-[ f ] [ f 0 head ] unit-test
-[ f ] [ [ 1 ] 0 head ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test
+[ f ] [ 0 f head ] unit-test
+[ f ] [ 0 [ 1 ] head ] unit-test
+[ [ 1 2 3 ] ] [ 3 [ 1 2 3 4 ] head ] unit-test
+[ f ] [ 3 [ 1 2 3 ] tail ] unit-test
+[ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test
IN: temporary
-
-USE: parser
-USE: test
-USE: words
-USE: strings
-USE: kernel
+USING: kernel parser sequences test words ;
DEFER: foo
! Test > 1 ( ) comment; only the first one should be used.
[ t ] [
- "a" "IN: temporary : foo ( a ) ( b ) ;" parse drop word
- "stack-effect" word-prop string-contains?
+ CHAR: a "IN: temporary : foo ( a ) ( b ) ;" parse drop word
+ "stack-effect" word-prop contains?
] unit-test
[ [ 4 3 2 1 ] ] [ 4 0 <range> >list ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ [ 2 3 ] ] [ 1 3 { 1 2 3 4 } <slice> >list ] unit-test
-[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice >vector ] unit-test
+[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test
+[ { 1 2 } { 3 4 } ] [ 2 { 1 2 3 4 } cut ] unit-test
+[ { 1 2 } { 4 5 } ] [ 2 { 1 2 3 4 5 } cut* ] unit-test
+[ { 3 4 } ] [ 2 4 1 10 <range> subseq ] unit-test
+[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq ] unit-test
[ "abc" ] [ "ab" "c" append ] unit-test
[ "abc" ] [ "a" "b" "c" append3 ] unit-test
-[ 3 ] [ "hola" "a" index-of ] unit-test
-[ -1 ] [ "hola" "x" index-of ] unit-test
-[ 0 ] [ "a" "" index-of ] unit-test
-[ 0 ] [ "" "" index-of ] unit-test
-[ 0 ] [ "hola" "hola" index-of ] unit-test
-[ 1 ] [ "hola" "ol" index-of ] unit-test
-[ -1 ] [ "hola" "amigo" index-of ] unit-test
-[ -1 ] [ "hola" "holaa" index-of ] unit-test
+[ 3 ] [ "a" "hola" seq-index ] unit-test
+[ -1 ] [ "x" "hola" seq-index ] unit-test
+[ 0 ] [ "" "a" seq-index ] unit-test
+[ 0 ] [ "" "" seq-index ] unit-test
+[ 0 ] [ "hola" "hola" seq-index ] unit-test
+[ 1 ] [ "ol" "hola" seq-index ] unit-test
+[ -1 ] [ "amigo" "hola" seq-index ] unit-test
+[ -1 ] [ "holaa" "hola" seq-index ] unit-test
-[ "Beginning" ] [ 9 "Beginning and end" string-head ] unit-test
+[ "Beginning" ] [ 9 "Beginning and end" head ] unit-test
-[ f ] [ "I" "team" string-contains? ] unit-test
-[ t ] [ "ea" "team" string-contains? ] unit-test
-[ f ] [ "actore" "Factor" string-contains? ] unit-test
+[ f ] [ CHAR: I "team" contains? ] unit-test
+[ t ] [ "ea" "team" subseq? ] unit-test
+[ f ] [ "actore" "Factor" subseq? ] unit-test
-[ "end" ] [ 14 "Beginning and end" string-tail ] unit-test
+[ "end" ] [ 14 "Beginning and end" tail ] unit-test
-[ "" 10 string/ ] unit-test-fails
+[ "" 10 cut ] unit-test-fails
-[ "Beginning" " and end" ] [ "Beginning and end" 9 string/ ] unit-test
+[ "Beginning" " and end" ] [ 9 "Beginning and end" cut ] unit-test
-[ "Beginning" "and end" ] [ "Beginning and end" 9 string// ] unit-test
+[ "Beginning" "and end" ] [ 9 "Beginning and end" cut* ] unit-test
[ "hello" "world" ] [ "hello world" " " split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
[ "" "" ] [ "great" "great" split1 ] unit-test
-[ "and end" t ] [ "Beginning and end" "Beginning " ?string-head ] unit-test
-[ "Beginning and end" f ] [ "Beginning and end" "Beginning x" ?string-head ] unit-test
-[ "Beginning and end" f ] [ "Beginning and end" "eginning " ?string-head ] unit-test
+[ "and end" t ] [ "Beginning and end" "Beginning " ?head ] unit-test
+[ "Beginning and end" f ] [ "Beginning and end" "Beginning x" ?head ] unit-test
+[ "Beginning and end" f ] [ "Beginning and end" "eginning " ?head ] unit-test
-[ "Beginning" t ] [ "Beginning and end" " and end" ?string-tail ] unit-test
-[ "Beginning and end" f ] [ "Beginning and end" "Beginning x" ?string-tail ] unit-test
-[ "Beginning and end" f ] [ "Beginning and end" "eginning " ?string-tail ] unit-test
+[ "Beginning" t ] [ "Beginning and end" " and end" ?tail ] unit-test
+[ "Beginning and end" f ] [ "Beginning and end" "Beginning x" ?tail ] unit-test
+[ "Beginning and end" f ] [ "Beginning and end" "eginning " ?tail ] unit-test
[ [ "This" "is" "a" "split" "sentence" ] ]
[ "This is a split sentence" " " split ]
[ [ "a" "b" "c" "d" "e" "f" ] ]
[ "aXXbXXcXXdXXeXXf" "XX" split ] unit-test
-[ "Hello world" t ] [ "Hello world\n" "\n" ?string-tail ] unit-test
-[ "Hello world" f ] [ "Hello world" "\n" ?string-tail ] unit-test
-[ "" t ] [ "\n" "\n" ?string-tail ] unit-test
-[ "" f ] [ "" "\n" ?string-tail ] unit-test
+[ "Hello world" t ] [ "Hello world\n" "\n" ?tail ] unit-test
+[ "Hello world" f ] [ "Hello world" "\n" ?tail ] unit-test
+[ "" t ] [ "\n" "\n" ?tail ] unit-test
+[ "" f ] [ "" "\n" ?tail ] unit-test
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
[ t ] [ "abc" "abd" string-compare 0 < ] unit-test
[ t ] [ "z" "abd" string-compare 0 > ] unit-test
-[ f ] [ [ 0 10 "hello" substring ] [ not ] catch ] unit-test
+[ f ] [ [ 0 10 "hello" subseq ] [ not ] catch ] unit-test
[ [ "hell" "o wo" "rld" ] ] [ 4 "hello world" split-n ] unit-test
[ 1 "" nth ] unit-test-fails
[ -6 "hello" nth ] unit-test-fails
+
+[ t ] [ "hello world" dup >list >string = ] unit-test
[ [ dup error. cons failure f ] [ t ] ifte* ] catch ;
: test-path ( name -- path )
- "/library/test/" swap ".factor" cat3 ;
+ "/library/test/" swap ".factor" append3 ;
: test ( name -- ? )
[
[ { 1 2 3 4 } ] [ [ { 1 } [ 2 ] { 3 4 } ] concat ] unit-test
[ { "" "a" "aa" "aaa" } ]
-[ 4 [ CHAR: a fill ] vector-project ]
+[ 4 [ CHAR: a fill ] project >vector ]
unit-test
-[ [ ] ] [ 0 { } vector-tail ] unit-test
-[ [ ] ] [ 2 { 1 2 } vector-tail ] unit-test
-[ [ 3 4 ] ] [ 2 { 1 2 3 4 } vector-tail ] unit-test
-[ 2 3 vector-tail ] unit-test-fails
+[ { } ] [ 0 { } tail ] unit-test
+[ { } ] [ 2 { 1 2 } tail ] unit-test
+[ { 3 4 } ] [ 2 { 1 2 3 4 } tail ] unit-test
-[ [ 3 ] ] [ 1 { 1 2 3 } vector-tail* ] unit-test
+[ { 3 } ] [ 1 { 1 2 3 } tail* ] unit-test
0 <vector> "funny-stack" set
! or single-stepping. Note that currently, words referring to
! annotated words cannot be compiled; and annotating a word has
! no effect of compiled calls to that word.
-USING: interpreter kernel lists prettyprint stdio strings test ;
+USING: interpreter kernel lists prettyprint sequences
+stdio strings test ;
: annotate ( word quot -- | quot: word def -- def )
over >r >r dup word-def r> call r> swap (define-compound) ;
inline
: (watch) ( word def -- def )
- >r "==> " swap word-name cat2 \ print \ .s r>
+ >r "==> " swap word-name append \ print \ .s r>
cons cons cons ;
: watch ( word -- )
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: words USING: kernel math namespaces strings unparser ;
+IN: words USING: kernel math namespaces sequences strings
+unparser ;
SYMBOL: gensym-count
: (gensym) ( -- name )
"G:" global [
gensym-count [ 1 + dup ] change
- ] bind unparse cat2 ;
+ ] bind unparse append ;
: gensym ( -- word )
#! Return a word that is distinct from every other word, and
: jedit-server-file ( -- path )
"jedit-server-file" get
- [ "~" get "/.jedit/server" cat2 ] unless* ;
+ [ "~" get "/.jedit/server" append ] unless* ;
: jedit-server-info ( -- port auth )
jedit-server-file <file-reader> [
] with-stream ;
: jedit-line/file ( file line -- )
- unparse "+line:" swap cat2 2list
+ unparse "+line:" swap append 2list
make-jedit-request send-jedit-request ;
: jedit-file ( file -- )
: vocab-apropos ( substring vocab -- list )
#! Push a list of all words in a vocabulary whose names
#! contain a string.
- words [ word-name dupd string-contains? ] subset nip ;
+ words [ word-name dupd subseq? ] subset nip ;
: vocab-apropos. ( substring vocab -- )
#! List all words in a vocabulary that contain a string.
: word-file ( word -- file )
"file" word-prop dup [
- "resource:/" ?string-head [
+ "resource:/" ?head [
resource-path swap path+
] when
] when ;
dup editor-actions ;
: offset>x ( offset str -- x )
- string-head font get swap size-string drop ;
+ head font get swap size-string drop ;
: caret-pos ( editor -- x y )
editor-line [ caret get line-text get ] bind offset>x 0 ;
#! Call this in the line editor scope.
reset-history
2dup caret-insert
- line-text get swap string/
- swapd cat3 line-text set ;
+ line-text get cut
+ swapd append3 line-text set ;
: insert-char ( ch -- )
#! Call this in the line editor scope.
#! Call this in the line editor scope.
reset-history
2dup caret-remove
- dupd + line-text get string-tail
- >r line-text get string-head r> cat2
+ dupd + line-text get tail
+ >r line-text get head r> append
line-text set ;
: backspace ( -- )
SYMBOL: fonts
: <font> ( name ptsize -- font )
- >r resource-path swap cat2 r> TTF_OpenFont ;
+ >r resource-path swap append r> TTF_OpenFont ;
SYMBOL: logical-fonts
] when drop ;
: filter-nulls ( str -- str )
- "\0" over string-contains? [
- [ dup CHAR: \0 = [ drop CHAR: \s ] when ] map
+ 0 over contains? [
+ [ dup 0 = [ drop CHAR: \s ] when ] map
] when ;
: size-string ( font text -- w h )
primitive_cons,
primitive_vector,
primitive_string_compare,
- primitive_index_of,
- primitive_substring,
+ primitive_rehash_string,
primitive_sbuf,
+ primitive_sbuf_to_string,
primitive_arithmetic_type,
primitive_to_fixnum,
primitive_to_bignum,
drepl(tag_object(sbuf(to_fixnum(dpeek()))));
}
+void primitive_sbuf_to_string(void)
+{
+ F_STRING* result;
+ F_SBUF* sbuf = untag_sbuf(dpeek());
+ F_STRING* string = untag_string(sbuf->string);
+ CELL length = untag_fixnum_fast(sbuf->top);
+
+ result = allot_string(length);
+ memcpy(result + 1,
+ (void*)((CELL)(string + 1)),
+ CHARS * length);
+ rehash_string(result);
+
+ drepl(tag_object(result));
+}
+
void fixup_sbuf(F_SBUF* sbuf)
{
data_fixup(&sbuf->string);
F_SBUF* sbuf(F_FIXNUM capacity);
void primitive_sbuf(void);
+void primitive_sbuf_to_string(void);
void fixup_sbuf(F_SBUF* sbuf);
void collect_sbuf(F_SBUF* sbuf);
str->hashcode = tag_fixnum(hash);
}
+void primitive_rehash_string(void)
+{
+ rehash_string(untag_string(dpop()));
+}
+
/* untagged */
F_STRING* string(CELL capacity, CELL fill)
{
dpush(tag_fixnum(string_compare(s1,s2)));
}
-
-CELL index_of_ch(CELL index, F_STRING* string, CELL ch)
-{
- CELL capacity = string_capacity(string);
-
- while(index < capacity)
- {
- if(string_nth(string,index) == ch)
- return index;
- index++;
- }
-
- return -1;
-}
-
-INLINE F_FIXNUM index_of_str(F_FIXNUM index, F_STRING* string, F_STRING* substring)
-{
- CELL i = index;
- CELL str_cap = string_capacity(string);
- CELL substr_cap = string_capacity(substring);
- F_FIXNUM limit = str_cap - substr_cap;
- CELL scan;
-
- if(substr_cap == 1)
- return index_of_ch(index,string,string_nth(substring,0));
-
- if(limit < 0)
- return -1;
-
-outer: if(i <= limit)
- {
- for(scan = 0; scan < substr_cap; scan++)
- {
- if(string_nth(string,i + scan) != string_nth(substring,scan))
- {
- i++;
- goto outer;
- }
- }
-
- /* We reached here and every char in the substring matched */
- return i;
- }
-
- /* We reached here and nothing matched */
- return -1;
-}
-
-/* index string substring -- index */
-void primitive_index_of(void)
-{
- CELL ch = dpop();
- F_STRING* string = untag_string(dpop());
- CELL capacity = string_capacity(string);
- F_FIXNUM index = to_fixnum(dpop());
- CELL result;
- if(index < 0 || index > capacity)
- {
- range_error(tag_object(string),0,tag_fixnum(index),capacity);
- result = -1; /* can't happen */
- }
- else if(TAG(ch) == FIXNUM_TYPE)
- result = index_of_ch(index,string,to_fixnum(ch));
- else
- result = index_of_str(index,string,untag_string(ch));
- dpush(tag_fixnum(result));
-}
-
-INLINE F_STRING* substring(CELL start, CELL end, F_STRING* string)
-{
- F_STRING* result;
- CELL capacity = string_capacity(string);
-
- if(start < 0)
- range_error(tag_object(string),0,tag_fixnum(start),capacity);
-
- if(end < start || end > capacity)
- range_error(tag_object(string),0,tag_fixnum(end),capacity);
-
- result = allot_string(end - start);
- memcpy(result + 1,
- (void*)((CELL)(string + 1) + CHARS * start),
- CHARS * (end - start));
- rehash_string(result);
-
- return result;
-}
-
-/* start end string -- string */
-void primitive_substring(void)
-{
- F_STRING* string;
- CELL end, start;
-
- maybe_garbage_collection();
-
- string = untag_string(dpop());
- end = to_fixnum(dpop());
- start = to_fixnum(dpop());
- dpush(tag_object(substring(start,end,string)));
-}
F_STRING* allot_string(CELL capacity);
F_STRING* string(CELL capacity, CELL fill);
void rehash_string(F_STRING* str);
+void primitive_rehash_string(void);
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
void primitive_grow_string(void);
char* to_c_string(F_STRING* s);
void primitive_set_char_slot(void);
F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
void primitive_string_compare(void);
-void primitive_index_of(void);
-void primitive_substring(void);
projects / factor.git / commitdiff