steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

more sequence cleanups

cvs
Slava Pestov 2005-05-18 20:26:22 +00:00
parent ac34c06c0c
commit 8d12fec3eb
59 changed files with 229 additions and 438 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
CHANGES.txt
View File

@ -16,10 +16,6 @@ Defining a predicate subclass of tuple is supported now. Note that
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.
@ -36,10 +32,28 @@ Note that GENERIC: foo is the same as
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:
------------

11
TODO.FACTOR.txt
View File

@ -10,9 +10,9 @@
- [ over ] generics no-method
- investigate if COPYING_GEN needs a fix
- simplifier:
- dead loads not optimized out
- kill tag-fixnum/untag-fixnum
- \ foo where foo is parsing is not printed readably
- kill replace after a peek
- merge inc-d's across VOPs that don't touch the stack
- faster layout
- tiled window manager
- c primitive arrays: or just specialized arrays
@ -28,17 +28,15 @@
- if external factor is down, don't add tons of random shit to the
dictionary
- SDL_Rect** type
- get all-tests to run with -no-compile
- fix i/o on generic x86/ppc unix
- alien primitives need a more general input type
- 2map slow with lists
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- faster sequence operations
- generic some? all? memq? all=? index? subseq?
- generic some? all? memq? all=?
- index and index* are very slow with lists
- unsafe-sbuf>string
- generic subseq
- code walker & exceptions
- if two tasks write to a unix stream, the buffer can overflow
- rename prettyprint to pprint
@ -89,7 +87,6 @@
- type inference fails with some assembler words;
displaced, register and other predicates need to inherit from list
not cons, and need stronger branch partial eval
- redo partial eval
- optimize away arithmetic dispatch
- dataflow optimizer needs eq not =
- the invalid recursion form case needs to be fixed, for inlines too
@ -99,7 +96,7 @@
+ sequences
- list map, subset: not tail recursive
- phase out sbuf-append, index-of, substring
- phase out sbuf-append
+ kernel:

2
library/alien/c-types.factor
View File

@ -20,7 +20,7 @@ SYMBOL: c-types
: 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 )

4
library/alien/structs.factor
View File

@ -15,12 +15,12 @@ math namespaces parser sequences strings words ;
: 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 + ;

3
library/bootstrap/boot-stage1.factor
View File

@ -31,9 +31,10 @@ hashtables sequences ;
"/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"

4
library/bootstrap/image.factor
View File

@ -195,7 +195,7 @@ M: cons ' ( c -- tagged )
( 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
@ -216,7 +216,7 @@ M: cons ' ( c -- tagged )
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 )

4
library/bootstrap/primitives.factor
View File

@ -44,9 +44,9 @@ vocabularies get [
[ "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 ] ] ]

6
library/cli.factor
View File

@ -22,7 +22,7 @@ sequences strings ;
: 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
@ -38,8 +38,8 @@ sequences strings ;
#! 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 )

12
library/collections/lists.factor
View File

@ -112,13 +112,17 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
: 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 ;

3
library/collections/sbuf.factor
View File

@ -21,5 +21,4 @@ M: sbuf set-nth ( ch n sbuf -- )
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 ;

44
library/collections/sequences-epilogue.factor
View File

@ -70,17 +70,17 @@ M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
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 > ;
@ -167,42 +167,6 @@ M: sequence = ( obj seq -- ? )
] 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 )

4
library/collections/sequences.factor
View File

@ -17,10 +17,13 @@ GENERIC: set-length ( n sequence -- )
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
@ -45,6 +48,7 @@ G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
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

56
library/collections/strings-epilogue.factor
View File

@ -1,24 +1,12 @@
! 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 )
@ -28,47 +16,17 @@ USING: generic kernel lists math namespaces sequences strings ;
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 ;

73
library/collections/strings.factor
View File

@ -29,75 +29,8 @@ M: string >string ;
! 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? ;
@ -106,7 +39,7 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ 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
@ -114,4 +47,4 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
dup letter?
over LETTER? or
over digit? or
swap "/_?." string-contains? or ;
swap "/_?." contains? or ;

24
library/collections/vectors-epilogue.factor
View File

@ -17,27 +17,11 @@ IN: vectors
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 ;

2
library/generic/generic.factor
View File

@ -8,7 +8,7 @@ math-internals ;
! 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:

2
library/httpd/cont-responder.factor
View File

@ -121,7 +121,7 @@ TUPLE: item expire? quot id time-added ;
: 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

2
library/httpd/file-responder.factor
View File

@ -36,7 +36,7 @@ stdio streams strings unparser ;
] ifte ;
: serve-directory ( filename -- )
"/" ?string-tail [
"/" ?tail [
dup "/index.html" append dup exists? [
serve-file
] [

12
library/httpd/html-tags.factor
View File

@ -64,7 +64,7 @@ USE: sequences
! <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>
@ -146,17 +146,17 @@ USE: sequences
: 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
] ;
@ -175,7 +175,7 @@ USE: sequences
: 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
] ;
@ -197,7 +197,7 @@ USE: sequences
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 ;

6
library/httpd/html.factor
View File

@ -66,8 +66,8 @@ stdio streams strings unparser http ;
#! 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 ;
@ -93,7 +93,7 @@ stdio streams strings unparser http ;
: 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

4
library/httpd/http-client.factor
View File

@ -9,13 +9,13 @@ stdio streams strings unparser ;
":" 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 )

2
library/httpd/http-common.factor
View File

@ -32,7 +32,7 @@ stdio streams strings unparser ;
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 )

8
library/httpd/httpd.factor
View File

@ -2,22 +2,22 @@
! 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 )
[

10
library/httpd/responder.factor
View File

@ -11,7 +11,7 @@ stdio streams strings ;
"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
@ -132,25 +132,25 @@ stdio streams strings ;
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

4
library/inference/branches.factor
View File

@ -8,7 +8,7 @@ sequences strings vectors words hashtables prettyprint ;
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.
@ -32,7 +32,7 @@ sequences strings vectors words hashtables prettyprint ;
#! 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

4
library/inference/dataflow.factor
View File

@ -24,8 +24,8 @@ TUPLE: node effect param in-d out-d in-r out-r
: 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> ;

4
library/inference/inference.factor
View File

@ -30,14 +30,14 @@ SYMBOL: d-in
: 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 ;

6
library/inference/partial-eval.factor
View File

@ -5,17 +5,17 @@ USING: generic interpreter kernel lists math namespaces
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 -- ? )

6
library/io/ansi.factor
View File

@ -2,7 +2,7 @@
! 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:
@ -32,11 +32,11 @@ C: ansi-stream ( stream -- stream ) [ set-delegate ] keep ;
: 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

4
library/io/directories.factor
View File

@ -19,13 +19,13 @@ sequences stdio streams strings unparser ;
: 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.

4
library/io/logging.factor
View File

@ -1,7 +1,7 @@
! 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
@ -14,7 +14,7 @@ SYMBOL: log-stream
print flush
] ifte* ;
: log-error ( error -- ) "Error: " swap cat2 log ;
: log-error ( error -- ) "Error: " swap append log ;
: log-client ( client-stream -- )
[

4
library/io/stream.factor
View File

@ -1,12 +1,12 @@
! 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

9
library/syntax/parse-numbers.factor
View File

@ -26,17 +26,18 @@ M: object digit> not-a-number ;
: 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 ;

2
library/syntax/parse-stream.factor
View File

@ -42,7 +42,7 @@ USING: kernel lists namespaces sequences streams strings ;
#! 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 ;

8
library/syntax/parse-syntax.factor
View File

@ -73,7 +73,11 @@ BUILTIN: f 9 not ;
: \
#! 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:
@ -130,7 +134,7 @@ BUILTIN: f 9 not ;
! Comments
: (
#! Stack comment.
")" until parsed-stack-effect ; parsing
CHAR: ) until parsed-stack-effect ; parsing
: !
#! EOL comment.

12
library/syntax/parse-words.factor
View File

@ -49,7 +49,7 @@ SYMBOL: file
: 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.
@ -76,16 +76,16 @@ global [ string-mode off ] bind
! 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
@ -108,7 +108,7 @@ global [ string-mode off ] bind
: 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 ;
@ -136,7 +136,7 @@ global [ string-mode off ] bind
: documentation+ ( word str -- )
over "documentation" word-prop [
swap "\n" swap cat3
swap "\n" swap append3
] when*
"documentation" set-word-prop ;

10
library/syntax/prettyprint.factor
View File

@ -68,7 +68,11 @@ M: word prettyprint* ( indent word -- indent )
: \? ( 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 ;
@ -77,7 +81,7 @@ M: word prettyprint* ( indent word -- indent )
[
dup \? [
\ \ word. bl
uncons >r car prettyprint* bl
uncons >r car word. bl
r> cdr prettyprint-elements
] [
uncons >r prettyprint* bl
@ -170,7 +174,7 @@ M: matrix prettyprint* ( indent obj -- indent )
] with-scope ;
: vocab-link ( vocab -- link )
"vocabularies'" swap cat2 ;
"vocabularies'" swap append ;
: . ( obj -- )
[

2
library/syntax/see.factor
View File

@ -68,7 +68,7 @@ namespaces sequences stdio streams strings unparser words ;
: documentation. ( indent word -- indent )
"documentation" word-prop [
"\n" split [
"#!" swap cat2 comment.
"#!" swap append comment.
dup prettyprint-newline
] each
] when* ;

4
library/syntax/unparser.factor
View File

@ -53,7 +53,7 @@ M: ratio unparse ( num -- str )
: 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 ;
@ -80,7 +80,7 @@ M: complex unparse ( num -- str )
] 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? [

4
library/test/benchmark/strings.factor
View File

@ -5,8 +5,8 @@ USING: compiler kernel math namespaces sequences strings test ;
: 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

2
library/test/line-editor.factor
View File

@ -28,7 +28,7 @@ USING: kernel line-editor namespaces sequences strings test ;
] 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 ]

8
library/test/lists/lists.factor
View File

@ -46,9 +46,11 @@ USING: kernel lists sequences test ;
[ [ ] ] [ 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

11
library/test/parsing-word.factor
View File

@ -1,10 +1,5 @@
IN: temporary
USE: parser
USE: test
USE: words
USE: strings
USE: kernel
USING: kernel parser sequences test words ;
DEFER: foo
@ -18,6 +13,6 @@ 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

6
library/test/sequences.factor
View File

@ -6,4 +6,8 @@ USING: lists sequences test vectors ;
[ [ 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

56
library/test/strings.factor
View File

@ -13,40 +13,40 @@ USE: lists
[ "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 ]
@ -59,10 +59,10 @@ unit-test
[ [ "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
@ -74,7 +74,7 @@ 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
@ -95,3 +95,5 @@ unit-test
[ 1 "" nth ] unit-test-fails
[ -6 "hello" nth ] unit-test-fails
[ t ] [ "hello world" dup >list >string = ] unit-test

2
library/test/test.factor
View File

@ -50,7 +50,7 @@ SYMBOL: failures
[ [ dup error. cons failure f ] [ t ] ifte* ] catch ;
: test-path ( name -- path )
"/library/test/" swap ".factor" cat3 ;
"/library/test/" swap ".factor" append3 ;
: test ( name -- ? )
[

11
library/test/vectors.factor
View File

@ -52,15 +52,14 @@ sequences strings test vectors ;
[ { 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

5
library/tools/annotations.factor
View File

@ -6,14 +6,15 @@ IN: words
! 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 -- )

5
library/tools/gensym.factor
View File

@ -1,13 +1,14 @@
! 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

4
library/tools/jedit.factor
View File

@ -6,7 +6,7 @@ streams strings unparser words ;
: 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> [
@ -31,7 +31,7 @@ streams strings unparser words ;
] 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 -- )

4
library/tools/word-tools.factor
View File

@ -8,7 +8,7 @@ hashtables parser ;
: 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.
@ -24,7 +24,7 @@ hashtables parser ;
: word-file ( word -- file )
"file" word-prop dup [
"resource:/" ?string-head [
"resource:/" ?head [
resource-path swap path+
] when
] when ;

2
library/ui/editors.factor
View File

@ -77,7 +77,7 @@ C: editor ( text -- )
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 ;

8
library/ui/line-editor.factor
View File

@ -109,8 +109,8 @@ SYMBOL: history-index
#! 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.
@ -132,8 +132,8 @@ SYMBOL: history-index
#! 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 ( -- )

6
library/ui/text.factor
View File

@ -7,7 +7,7 @@ streams strings ;
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
@ -51,8 +51,8 @@ global [
] 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 )

4
native/primitives.c
View File

@ -10,9 +10,9 @@ void* primitives[] = {
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,

16
native/sbuf.c
View File

@ -17,6 +17,22 @@ void primitive_sbuf(void)
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);

1
native/sbuf.h
View File

@ -21,5 +21,6 @@ INLINE F_SBUF* untag_sbuf(CELL tagged)
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);

106
native/string.c
View File

@ -25,6 +25,11 @@ void rehash_string(F_STRING* str)
str->hashcode = tag_fixnum(hash);
}
void primitive_rehash_string(void)
{
rehash_string(untag_string(dpop()));
}
/* untagged */
F_STRING* string(CELL capacity, CELL fill)
{
@ -196,104 +201,3 @@ void primitive_string_compare(void)
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)));
}

3
native/string.h
View File

@ -30,6 +30,7 @@ INLINE CELL string_capacity(F_STRING* str)
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);
@ -59,5 +60,3 @@ void primitive_char_slot(void);
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);