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

Merge git://factorcode.org/git/factor 

Conflicts:

	extra/http/http.factor
db4
Doug Coleman 2008-02-01 22:47:05 -06:00
parent 004dd0dc5e 2d381ed84e
commit ea8ad2b04c
47 changed files with 189 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
core/parser/parser.factor
View File

@ -347,45 +347,49 @@ SYMBOL: bootstrap-syntax
call
] with-scope ; inline
SYMBOL: interactive-vocabs
{
"arrays"
"assocs"
"combinators"
"compiler.errors"
"continuations"
"debugger"
"definitions"
"editors"
"generic"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} interactive-vocabs set-global
: with-interactive-vocabs ( quot -- )
[
"scratchpad" in set
{
"arrays"
"assocs"
"combinators"
"compiler.errors"
"continuations"
"debugger"
"definitions"
"editors"
"generic"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} set-use
interactive-vocabs get set-use
call
] with-scope ; inline

5
core/strings/strings-tests.factor
View File

@ -51,6 +51,9 @@ unit-test
[ "ab" ] [ 2 "abc" resize-string ] unit-test
[ "abc\0\0\0" ] [ 6 "abc" resize-string ] unit-test
[ "\u001234b" ] [ 2 "\u001234bc" resize-string ] unit-test
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
[ { "kernel-error" 3 12 -7 } ]
[ [ 2 -7 resize-string ] catch ] unit-test
@ -88,3 +91,5 @@ unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test

2
extra/benchmark/knucleotide/knucleotide.factor
View File

@ -1,6 +1,6 @@
USING: kernel io io.files splitting strings
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting ;
math.parser combinators arrays sorting unicode.case ;
IN: benchmark.knucleotide

2
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
hints ;
hints unicode.case ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )

14
extra/builder/builder.factor
View File

@ -1,5 +1,5 @@
USING: kernel io io.files io.launcher
USING: kernel io io.files io.launcher tools.deploy.backend
system namespaces sequences splitting math.parser
unix prettyprint tools.time calendar bake vars ;
@ -31,8 +31,6 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ;
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -61,7 +59,7 @@ if
"factor" cd
{ "/usr/bin/git" "show" } <process-stream>
{ "git" "show" } <process-stream>
[ readln ] with-stream
" " split second
"../git-id" <file-writer> [ print ] with-stream
@ -76,7 +74,7 @@ if
"builder: vm compile" throw
] if
"wget http://factorcode.org/images/latest/" boot-image append system
"wget http://factorcode.org/images/latest/" boot-image-name append system
0 =
[ ]
[
@ -84,7 +82,11 @@ if
"builder: image download" throw
] if
[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ]
[
"./factor -i=" boot-image-name " -no-user-init > ../boot-log"
3append
system
]
benchmark nip
"../boot-time" <file-writer> [ . ] with-stream
0 =

2
extra/cryptlib/cryptlib.factor
View File

@ -6,7 +6,7 @@
! Adapted from cryptlib.h
! Tested with cryptlib 3.3.1.0
USING: cryptlib.libcl kernel hashtables alien math
namespaces sequences assocs libc alien.c-types continuations ;
namespaces sequences assocs libc alien.c-types alien.accessors continuations ;
IN: cryptlib

4
extra/cryptlib/streams/streams.factor
View File

@ -3,7 +3,7 @@
USING: cryptlib cryptlib.libcl kernel alien sequences continuations
byte-arrays namespaces io.buffers math generic io strings
io.streams.lines io.streams.plain io.streams.duplex combinators
alien.c-types ;
alien.c-types continuations ;
IN: cryptlib.streams
@ -154,4 +154,4 @@ M: crypt-stream dispose ( stream -- )
dispose
end
;
;

2
extra/fjsc/fjsc.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg strings promises sequences math math.parser
namespaces words quotations arrays hashtables io
io.streams.string assocs memoize ;
io.streams.string assocs memoize ascii ;
IN: fjsc
TUPLE: ast-number value ;

2
extra/globs/globs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lazy-lists sequences kernel
promises strings ;
promises strings unicode.case ;
IN: globs
<PRIVATE

4
extra/hexdump/hexdump.factor
View File

@ -1,6 +1,6 @@
USING: arrays combinators.lib io io.streams.string
kernel math math.parser namespaces prettyprint
sequences splitting strings ;
kernel math math.parser namespaces prettyprint
sequences splitting strings ascii ;
IN: hexdump
<PRIVATE

2
extra/html/elements/elements.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer xml.entities compiler.units effects ;
sequences strings words xml.entities compiler.units effects ;
IN: html.elements

2
extra/html/html.factor
View File

@ -3,7 +3,7 @@
USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.parser namespaces
quotations assocs sequences strings words html.elements
xml.writer xml.entities sbufs ;
xml.entities sbufs continuations ;
IN: html
GENERIC: browser-link-href ( presented -- href )

2
extra/http/http-tests.factor
View File

@ -14,3 +14,5 @@ IN: temporary
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test

21
extra/http/http.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting assocs.lib ;
sequences strings splitting ascii io.utf8 assocs.lib ;
IN: http
: header-line ( line -- )
@ -20,18 +20,15 @@ IN: http
dup letter?
over LETTER? or
over digit? or
swap "/_-?." member? or ; foldable
swap "/_-." member? or ; foldable
: push-utf8 ( string -- )
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[
dup url-quotable? [
,
] [
CHAR: % , >hex 2 CHAR: 0 pad-left %
] if
] each
] "" make ;
[ [
dup url-quotable? [ , ] [ push-utf8 ] if
] each ] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
@ -58,7 +55,7 @@ IN: http
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make ;
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
: hash>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map

2
extra/http/server/templating/templating.factor
View File

@ -25,7 +25,7 @@ M: template-lexer skip-word
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ [ blank? ] skip ] }
{ [ t ] [ f skip ] }
} cond
] change-column ;

2
extra/id3/id3.factor
View File

@ -4,7 +4,7 @@
USING: arrays combinators io io.binary io.files io.paths
io.utf16 kernel math math.parser namespaces sequences
splitting strings assocs ;
splitting strings assocs unicode.categories ;
IN: id3

6
extra/io/server/server.factor
View File

@ -29,7 +29,7 @@ SYMBOL: log-stream
: with-log-file ( file quot -- )
>r <file-appender> r>
[ with-log-stream ] with-disposal ; inline
[ with-log-stream ] curry with-disposal ; inline
: with-log-stdio ( quot -- )
stdio get swap with-log-stream ;
@ -47,11 +47,11 @@ SYMBOL: log-stream
dup log-client
[ swap with-stream ] 2curry concurrency:spawn drop ; inline
: accept-loop ( server quot -- server quot )
: accept-loop ( server quot -- )
[ swap accept with-client ] 2keep accept-loop ; inline
: server-loop ( server quot -- )
[ accept-loop ] compose with-disposal ; inline
[ accept-loop ] curry with-disposal ; inline
: spawn-server ( addrspec quot -- )
"Waiting for connections on " pick unparse append

2
extra/io/sniffer/bsd/bsd.factor
View File

@ -7,7 +7,7 @@ sequences io.sniffer.backend ;
QUALIFIED: unix
IN: io.sniffer.bsd
M: unix-io destruct-handle ( obj -- ) close drop ;
M: unix-io destruct-handle ( obj -- ) unix:close drop ;
C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;

2
extra/irc/irc.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar io io.sockets kernel match namespaces
sequences splitting strings continuations threads ;
sequences splitting strings continuations threads ascii ;
IN: irc
! "setup" objects

2
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions
lazy-lists hashtables ;
lazy-lists hashtables ascii ;
IN: json.reader
! Grammar for JSON from RFC 4627

5
extra/lint/lint.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs combinators.lib io kernel
USING: alien alien.accessors arrays assocs combinators.lib io kernel
macros math namespaces prettyprint quotations sequences
vectors vocabs words ;
USING: html.elements slots.private tar ;
vectors vocabs words html.elements slots.private tar ;
IN: lint
SYMBOL: def-hash

2
extra/parser-combinators/simple/simple.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings math sequences lazy-lists words
math.parser promises parser-combinators ;
math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple
: 'digit' ( -- parser )

3
extra/peg/ebnf/ebnf.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
quotations vectors namespaces math assocs continuations peg
unicode.categories ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;

3
extra/peg/peg.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match ;
vectors arrays combinators.lib memoize math.parser match
unicode.categories ;
IN: peg
TUPLE: parse-result remaining ast ;

3
extra/project-euler/017/017.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.ranges math.text.english sequences strings ;
USING: combinators.lib kernel math.ranges math.text.english sequences strings
ascii ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17

2
extra/project-euler/022/022.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel math math.parser namespaces sequences sorting splitting
strings system vocabs ;
strings system vocabs ascii ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22

2
extra/prolog/prolog.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays vectors namespaces math strings
combinators continuations quotations io assocs ;
combinators continuations quotations io assocs ascii ;
IN: prolog

2
extra/regexp/regexp.factor
View File

@ -1,7 +1,7 @@
USING: arrays combinators kernel lazy-lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings
assocs prettyprint.backend memoize ;
assocs prettyprint.backend memoize unicode.case unicode.categories ;
USE: io
IN: regexp

2
extra/roman/roman.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.vectors namespaces
quotations sequences sequences.lib sequences.private strings ;
quotations sequences sequences.lib sequences.private strings unicode.case ;
IN: roman
<PRIVATE

2
extra/rot13/rot13.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences strings io combinators ;
USING: kernel math sequences strings io combinators ascii ;
IN: rot13
: rotate ( ch base -- ch ) tuck - 13 + 26 mod + ;

4
extra/sequences/lib/lib.factor
View File

@ -1,6 +1,6 @@
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors ;
USING: arrays math.parser sorting strings ;
random sequences.private shuffle math.functions mirrors
arrays math.parser sorting strings ascii ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/state-parser/state-parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel math namespaces sequences
strings circular prettyprint debugger ;
strings circular prettyprint debugger unicode.categories ;
IN: state-parser
! * Basic underlying words

16
extra/strings/lib/lib.factor
View File

@ -1,14 +1,14 @@
USING: math arrays sequences kernel splitting strings ;
IN: strings.lib
: char>digit ( c -- i ) 48 - ;
! : char>digit ( c -- i ) 48 - ;
: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
! : string>digits ( s -- seq ) [ char>digit ] { } map-as ;
: >Upper ( str -- str )
dup empty? [
unclip ch>upper 1string swap append
] unless ;
! : >Upper ( str -- str )
! dup empty? [
! unclip ch>upper 1string swap append
! ] unless ;
: >Upper-dashes ( str -- str )
"-" split [ >Upper ] map "-" join ;
! : >Upper-dashes ( str -- str )
! "-" split [ >Upper ] map "-" join ;

8
extra/tar/tar.factor
View File

@ -1,6 +1,8 @@
USING: combinators io io.files io.streams.duplex continuations
io.streams.string kernel math math.parser
namespaces pack prettyprint sequences strings system hexdump ;
<<<<<<< HEAD:extra/tar/tar.factor
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system ;
USING: hexdump tools.interpreter ;
IN: tar
: zero-checksum 256 ;

15
extra/unicode/case/case.factor
View File

@ -1,5 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces assocs.lib
unicode.normalize math unicode.categories combinators assocs ;
USING: kernel unicode.data sequences sequences.next namespaces
assocs.lib unicode.normalize math unicode.categories combinators
assocs ;
IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ;
@ -20,7 +21,7 @@ SYMBOL: locale ! Just casing locale, or overall?
[ swap dot-over = over "ij" member? and swap , ] if ;
: lithuanian>upper ( string -- lower )
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make* ;
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
: mark-above? ( ch -- ? )
combining-class 230 = ;
@ -32,14 +33,14 @@ SYMBOL: locale ! Just casing locale, or overall?
dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
: lithuanian>lower ( string -- lower )
[ [ lithuanian-ch>lower ] each-next ] "" make* ;
[ [ lithuanian-ch>lower ] each-next ] "" make ;
: turk-ch>upper ( ch -- )
dup CHAR: i =
[ drop CHAR: I , dot-over , ] [ , ] if ;
: turk>upper ( string -- upper-i )
[ [ turk-ch>upper ] each ] "" make* ;
[ [ turk-ch>upper ] each ] "" make ;
: turk-ch>lower ( ? next ch -- ? )
{
@ -52,7 +53,7 @@ SYMBOL: locale ! Just casing locale, or overall?
} cond ;
: turk>lower ( string -- lower-i )
[ f swap [ turk-ch>lower ] each-next drop ] "" make* ;
[ f swap [ turk-ch>lower ] each-next drop ] "" make ;
: word-boundary ( prev char -- new ? )
dup non-starter? [ drop dup ] when
@ -76,7 +77,7 @@ SYMBOL: locale ! Just casing locale, or overall?
[ -rot nip call , ] ?if
] 2keep
] each 2drop
] "" make* ; inline
] "" make ; inline
: >lower ( string -- lower )
i-dot? [ turk>lower ] when

11
extra/unicode/normalize/normalize.factor
View File

@ -2,17 +2,6 @@ USING: sequences namespaces unicode.data kernel combinators.lib
math arrays ;
IN: unicode.normalize
! Utility word--probably unnecessary
: make* ( seq quot exemplar -- newseq )
! quot has access to original seq on stack
! this just makes the new-resizable the same length as seq
[
[
pick length swap new-resizable
[ building set call ] keep
] keep like
] with-scope ; inline
! Conjoining Jamo behavior
: hangul-base HEX: ac00 ; inline

6
extra/webapps/cgi/cgi.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.responders webapps.file
sequences strings math.parser ;
sequences strings math.parser unicode.case ;
IN: webapps.cgi
SYMBOL: cgi-root
@ -31,7 +31,7 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set
"Cookie" header-param "HTTP_COOKIE" set
"Cookie" header-param "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set

4
extra/webapps/pastebin/pastebin.factor
View File

@ -1,6 +1,6 @@
USING: calendar furnace furnace.validator io.files kernel
namespaces sequences http.server.responders html math math.parser rss
xml.writer xmode.code2html ;
namespaces sequences http.server.responders html math.parser rss
xml.writer xmode.code2html math ;
IN: webapps.pastebin
TUPLE: pastebin pastes ;

8
extra/wrap/wrap.factor
View File

@ -12,15 +12,17 @@ SYMBOL: width
: (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip
[ cut-slice swap , (split-chunk) ] [ , ] if* ;
[ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
: split-chunk ( words -- lines )
[ (split-chunk) ] { } make ;
: join-spaces ( words-seqs -- lines )
[ [ " " join ] map ] map concat ;
: broken-lines ( string width -- lines )
width [
line-chunks
[ split-chunk [ " " join ] map ] map concat
line-chunks [ split-chunk ] map join-spaces
] with-variable ;
: line-break ( string width -- newstring )

2
extra/xml/tokenize/tokenize.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes
xml.entities kernel state-parser kernel namespaces strings math
math.parser sequences assocs arrays splitting combinators ;
math.parser sequences assocs arrays splitting combinators unicode.case ;
IN: xml.tokenize
! XML namespace processing: ns = namespace

2
extra/xml/xml.factor
View File

@ -3,7 +3,7 @@
USING: io io.streams.string io.files kernel math namespaces
prettyprint sequences arrays generic strings vectors
xml.char-classes xml.data xml.errors xml.tokenize xml.writer
xml.utilities state-parser assocs ;
xml.utilities state-parser assocs unicode.categories ;
IN: xml
! -- Overall parser with data tree

3
extra/xmode/keyword-map/keyword-map.factor
View File

@ -1,4 +1,5 @@
USING: kernel strings assocs sequences hashtables sorting ;
USING: kernel strings assocs sequences hashtables sorting
unicode.case unicode.categories ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap

2
extra/xmode/marker/marker.factor
View File

@ -2,7 +2,7 @@ IN: xmode.marker
USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib
strings regexp splitting parser-combinators ;
strings regexp splitting parser-combinators ascii unicode.case ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker

2
extra/xmode/rules/rules.factor
View File

@ -1,5 +1,5 @@
USING: xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize regexp ;
sequences vectors assocs strings memoize regexp unicode.case ;
IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;

3
vm/data_gc.c
View File

@ -505,7 +505,6 @@ CELL binary_payload_start(CELL pointer)
switch(untag_header(get(pointer)))
{
/* these objects do not refer to other objects at all */
case STRING_TYPE:
case FLOAT_TYPE:
case BYTE_ARRAY_TYPE:
case BIT_ARRAY_TYPE:
@ -522,6 +521,8 @@ CELL binary_payload_start(CELL pointer)
return CELLS * 2;
case QUOTATION_TYPE:
return sizeof(F_QUOTATION) - CELLS * 2;
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */
default:
return unaligned_object_size(pointer);

52
vm/types.c
View File

@ -431,23 +431,30 @@ CELL string_nth(F_STRING* string, CELL index)
}
}
/* allocates memory */
void set_string_nth(F_STRING* string, CELL index, CELL value)
{
bput(SREF(string,index),value & 0xff);
F_BYTE_ARRAY *aux;
if(string->aux == F)
{
if(value <= 0xff)
return;
else
{
string->aux = tag_object(allot_byte_array(
REGISTER_UNTAGGED(string);
aux = allot_byte_array(
untag_fixnum_fast(string->length)
* sizeof(u16)));
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
string->aux = tag_object(aux);
}
}
else
aux = untag_object(string->aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
cput(BREF(aux,index * sizeof(u16)),value >> 8);
}
@ -463,20 +470,36 @@ F_STRING* allot_string_internal(CELL capacity)
string->length = tag_fixnum(capacity);
string->hashcode = F;
string->aux = F;
set_string_nth(string,capacity,0);
return string;
}
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
if(fill == 0)
memset((void*)SREF(string,start),'\0',capacity - start);
{
memset((void *)SREF(string,start),'\0',capacity - start);
if(string->aux != F)
{
F_BYTE_ARRAY *aux = untag_object(string->aux);
memset((void *)BREF(aux,start * sizeof(u16)),'\0',
(capacity - start) * sizeof(u16));
}
}
else
{
CELL i;
for(i = start; i < capacity; i++)
{
REGISTER_UNTAGGED(string);
set_string_nth(string,i,fill);
UNREGISTER_UNTAGGED(string);
}
}
}
@ -484,7 +507,9 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
F_STRING *allot_string(CELL capacity, CELL fill)
{
F_STRING* string = allot_string_internal(capacity);
REGISTER_UNTAGGED(string);
fill_string(string,0,capacity,fill);
UNREGISTER_UNTAGGED(string);
return string;
}
@ -506,7 +531,23 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
UNREGISTER_UNTAGGED(string);
memcpy(new_string + 1,string + 1,to_copy);
if(string->aux != F)
{
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
new_string->aux = tag_object(new_aux);
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
REGISTER_UNTAGGED(string);
fill_string(new_string,to_copy,capacity,fill);
UNREGISTER_UNTAGGED(string);
return new_string;
}
@ -529,7 +570,9 @@ DEFINE_PRIMITIVE(resize_string)
CELL i; \
for(i = 0; i < length; i++) \
{ \
REGISTER_UNTAGGED(s); \
set_string_nth(s,i,(utype)*string); \
UNREGISTER_UNTAGGED(s); \
string++; \
} \
return s; \
@ -552,6 +595,7 @@ DEFINE_PRIMITIVE(resize_string)
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)
bool check_string(F_STRING *s, CELL max)
{

4
vm/types.h
View File

@ -83,8 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array)
return array->capacity >> TAG_BITS;
}
#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index)
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index)
#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
INLINE F_STRING* untag_string(CELL tagged)
{