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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Daniel Ehrenberg 2008-02-02 00:25:24 -06:00
parent c584e50c04 68b3d8e1d9
commit 950e376f95
53 changed files with 237 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
core/bootstrap/primitives.factor
View File

@ -15,12 +15,12 @@ crossref off
"resource:core/bootstrap/syntax.factor" parse-file "resource:core/bootstrap/syntax.factor" parse-file
"resource:core/cpu/" architecture get { "resource:core/cpu/" architecture get {
{ "x86.32" "x86/32" } { "x86.32" "x86/32" }
{ "x86.64" "x86/64" } { "x86.64" "x86/64" }
{ "linux-ppc" "ppc/linux" } { "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" } { "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" } { "arm" "arm" }
} at "/bootstrap.factor" 3append parse-file } at "/bootstrap.factor" 3append parse-file
"resource:core/bootstrap/layouts/layouts.factor" parse-file "resource:core/bootstrap/layouts/layouts.factor" parse-file
@ -626,7 +626,7 @@ builtins get num-tags get tail f union-class define-class
{ "<float-array>" "float-arrays" } { "<float-array>" "float-arrays" }
{ "curry" "kernel" } { "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" } { "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" } { "class-hash" "kernel.private" }
{ "callstack>array" "kernel" } { "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" } { "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" } { "innermost-frame-scan" "kernel.private" }

91
core/parser/parser.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math USING: arrays definitions generic assocs kernel math
namespaces prettyprint sequences strings vectors words namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger splitting math.parser effects continuations debugger
io.files io.streams.string io.streams.lines vocabs io.files io.streams.string io.streams.lines vocabs
source-files classes hashtables compiler.errors compiler.units source-files classes hashtables compiler.errors compiler.units ;
ascii ;
IN: parser IN: parser
TUPLE: lexer text line column ; TUPLE: lexer text line column ;
@ -55,8 +54,9 @@ t parser-notes set-global
0 over set-lexer-column 0 over set-lexer-column
dup lexer-line 1+ swap set-lexer-line ; dup lexer-line 1+ swap set-lexer-line ;
: skip ( i seq quot -- n ) : skip ( i seq ? -- n )
over >r find* drop over >r
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ; inline [ r> drop ] [ r> length ] if* ; inline
: change-column ( lexer quot -- ) : change-column ( lexer quot -- )
@ -67,14 +67,13 @@ t parser-notes set-global
GENERIC: skip-blank ( lexer -- ) GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- ) M: lexer skip-blank ( lexer -- )
[ [ blank? not ] skip ] change-column ; [ t skip ] change-column ;
GENERIC: skip-word ( lexer -- ) GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- ) M: lexer skip-word ( lexer -- )
[ [
2dup nth CHAR: " = 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if
[ drop 1+ ] [ [ blank? ] skip ] if
] change-column ; ] change-column ;
: still-parsing? ( lexer -- ? ) : still-parsing? ( lexer -- ? )
@ -348,45 +347,49 @@ SYMBOL: bootstrap-syntax
call call
] with-scope ; inline ] 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 -- ) : with-interactive-vocabs ( quot -- )
[ [
"scratchpad" in set "scratchpad" in set
{ interactive-vocabs get set-use
"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
call call
] with-scope ; inline ] with-scope ; inline

25
core/prettyprint/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects prettyprint.sections quotations io io.files math.parser effects
tuples classes float-arrays float-vectors ascii ; tuples classes float-arrays float-vectors ;
IN: prettyprint.backend IN: prettyprint.backend
GENERIC: pprint* ( obj -- ) GENERIC: pprint* ( obj -- )
@ -58,24 +58,17 @@ M: f pprint* drop \ f pprint-word ;
! Strings ! Strings
: ch>ascii-escape ( ch -- str ) : ch>ascii-escape ( ch -- str )
H{ H{
{ CHAR: \e "\\e" } { CHAR: \e CHAR: e }
{ CHAR: \n "\\n" } { CHAR: \n CHAR: n }
{ CHAR: \r "\\r" } { CHAR: \r CHAR: r }
{ CHAR: \t "\\t" } { CHAR: \t CHAR: t }
{ CHAR: \0 "\\0" } { CHAR: \0 CHAR: 0 }
{ CHAR: \\ "\\\\" } { CHAR: \\ CHAR: \\ }
{ CHAR: \" "\\\"" } { CHAR: \" CHAR: \" }
} at ; } at ;
: ch>unicode-escape ( ch -- str )
>hex 6 CHAR: 0 pad-left "\\u" swap append ;
: unparse-ch ( ch -- ) : unparse-ch ( ch -- )
dup quotable? [ dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
,
] [
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
] if ;
: do-string-limit ( str -- trimmed ) : do-string-limit ( str -- trimmed )
string-limit get [ string-limit get [

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

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

2
core/strings/strings.factor
View File

@ -38,7 +38,7 @@ M: string set-nth-unsafe
>r >fixnum >r >fixnum r> r> set-string-nth ; >r >fixnum >r >fixnum r> r> set-string-nth ;
M: string clone M: string clone
(clone) dup string-aux clone over set-string-aux ; (clone) dup string-aux clone over set-string-aux ;
M: string resize resize-string ; M: string resize resize-string ;

0
core/ascii/ascii-docs.factor → extra/ascii/ascii-docs.factor
View File

0
core/ascii/ascii-tests.factor → extra/ascii/ascii-tests.factor
View File

2
core/ascii/ascii.factor → extra/ascii/ascii.factor
View File

@ -24,5 +24,3 @@ IN: ascii
: alpha? ( ch -- ? ) : alpha? ( ch -- ? )
dup Letter? [ drop t ] [ digit? ] if ; inline dup Letter? [ drop t ] [ digit? ] if ; inline

0
core/ascii/authors.txt → extra/ascii/authors.txt
View File

0
core/ascii/summary.txt → extra/ascii/summary.txt
View File

0
core/ascii/tags.txt → extra/ascii/tags.txt
View File

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

@ -1,6 +1,6 @@
USING: kernel io io.files splitting strings USING: kernel io io.files splitting strings
hashtables sequences assocs math namespaces prettyprint hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting ; math.parser combinators arrays sorting unicode.case ;
IN: benchmark.knucleotide 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 USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting sequences.private strings vectors words memoize splitting
hints ; hints unicode.case ;
IN: benchmark.reverse-complement IN: benchmark.reverse-complement
MEMO: trans-map ( -- str ) 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 system namespaces sequences splitting math.parser
unix prettyprint tools.time calendar bake vars ; 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 ; : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -61,7 +59,7 @@ if
"factor" cd "factor" cd
{ "/usr/bin/git" "show" } <process-stream> { "git" "show" } <process-stream>
[ readln ] with-stream [ readln ] with-stream
" " split second " " split second
"../git-id" <file-writer> [ print ] with-stream "../git-id" <file-writer> [ print ] with-stream
@ -76,7 +74,7 @@ if
"builder: vm compile" throw "builder: vm compile" throw
] if ] if
"wget http://factorcode.org/images/latest/" boot-image append system "wget http://factorcode.org/images/latest/" boot-image-name append system
0 = 0 =
[ ] [ ]
[ [
@ -84,7 +82,11 @@ if
"builder: image download" throw "builder: image download" throw
] if ] 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 benchmark nip
"../boot-time" <file-writer> [ . ] with-stream "../boot-time" <file-writer> [ . ] with-stream
0 = 0 =

2
extra/cryptlib/cryptlib.factor
View File

@ -6,7 +6,7 @@
! Adapted from cryptlib.h ! Adapted from cryptlib.h
! Tested with cryptlib 3.3.1.0 ! Tested with cryptlib 3.3.1.0
USING: cryptlib.libcl kernel hashtables alien math 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 IN: cryptlib

2
extra/fjsc/fjsc.factor
View File

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

2
extra/globs/globs.factor
View File

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

4
extra/hexdump/hexdump.factor
View File

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

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

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

2
extra/id3/id3.factor
View File

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

33
extra/io/monitor/monitor-docs.factor
View File

@ -8,35 +8,32 @@ $nl
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; "Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
HELP: next-change HELP: next-change
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } } { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } }
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ; { $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ;
HELP: with-monitor HELP: with-monitor
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
HELP: +change-file+ HELP: +add-file+
{ $description "Indicates that the contents of the file have changed." } ; { $description "Indicates that the file has been added to the directory." } ;
HELP: +change-name+ HELP: +remove-file+
{ $description "Indicates that the file name has changed." } ; { $description "Indicates that the file has been removed from the directory." } ;
HELP: +change-size+ HELP: +modify-file+
{ $description "Indicates that the file size has changed." } ; { $description "Indicates that the file contents have changed." } ;
HELP: +change-attributes+ HELP: +rename-file+
{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ; { $description "Indicates that file has been renamed." } ;
HELP: +change-modified+
{ $description "Indicates that the last modification time of the file has changed." } ;
ARTICLE: "io.monitor.descriptors" "File system change descriptors" ARTICLE: "io.monitor.descriptors" "File system change descriptors"
"Change descriptors output by " { $link next-change } ":" "Change descriptors output by " { $link next-change } ":"
{ $subsection +change-file+ } { $subsection +add-file+ }
{ $subsection +change-name+ } { $subsection +remove-file+ }
{ $subsection +change-size+ } { $subsection +modify-file+ }
{ $subsection +change-attributes+ } { $subsection +rename-file+ }
{ $subsection +change-modified+ } ; { $subsection +add-file+ } ;
ARTICLE: "io.monitor" "File system change monitors" ARTICLE: "io.monitor" "File system change monitors"
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."

9
extra/io/monitor/monitor.factor
View File

@ -7,11 +7,10 @@ HOOK: <monitor> io-backend ( path recursive? -- monitor )
HOOK: next-change io-backend ( monitor -- path changes ) HOOK: next-change io-backend ( monitor -- path changes )
SYMBOL: +change-file+ SYMBOL: +add-file+
SYMBOL: +change-name+ SYMBOL: +remove-file+
SYMBOL: +change-size+ SYMBOL: +modify-file+
SYMBOL: +change-attributes+ SYMBOL: +rename-file+
SYMBOL: +change-modified+
: with-monitor ( path recursive? quot -- ) : with-monitor ( path recursive? quot -- )
>r <monitor> r> with-disposal ; inline >r <monitor> r> with-disposal ; inline

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

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

11
extra/io/windows/launcher/launcher.factor
View File

@ -119,8 +119,15 @@ TUPLE: CreateProcess-args
drop STD_ERROR_HANDLE GetStdHandle ; drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle ) : redirect-stderr ( args -- handle )
+stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect +stderr+ get
swap inherited-stderr ?closed ; dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo
STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle ) : inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe CreateProcess-args-stdin-pipe

32
extra/io/windows/nt/monitor/monitor.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types destructors io.windows
io.windows.nt.backend kernel math windows windows.kernel32 io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations windows.types libc assocs alien namespaces continuations
io.monitor io.nonblocking io.buffers io.files io sequences io.monitor io.nonblocking io.buffers io.files io sequences
hashtables sorting arrays ; hashtables sorting arrays combinators ;
IN: io.windows.nt.monitor IN: io.windows.nt.monitor
TUPLE: monitor path recursive? queue closed? ; TUPLE: monitor path recursive? queue closed? ;
@ -53,25 +53,17 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
] with-port-timeout ] with-port-timeout
] with-destructors ; ] with-destructors ;
: parse-action-flag ( action mask symbol -- action ) : parse-action ( action -- changed )
>r over bitand 0 > [ r> , ] [ r> drop ] if ; {
{ [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] }
{ [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] }
{ [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] }
{ [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] }
{ [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] }
{ [ t ] [ +modify-file+ ] }
} cond nip ;
: parse-action ( action -- changes ) : changed-file ( directory buffer -- changed path )
[
FILE_NOTIFY_CHANGE_FILE +change-file+ parse-action-flag
FILE_NOTIFY_CHANGE_DIR_NAME +change-name+ parse-action-flag
FILE_NOTIFY_CHANGE_ATTRIBUTES +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_SIZE +change-size+ parse-action-flag
FILE_NOTIFY_CHANGE_LAST_WRITE +change-modified+ parse-action-flag
FILE_NOTIFY_CHANGE_LAST_ACCESS +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_EA +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_CREATION +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_SECURITY +change-attributes+ parse-action-flag
FILE_NOTIFY_CHANGE_FILE_NAME +change-name+ parse-action-flag
drop
] { } make ;
: changed-file ( directory buffer -- changes path )
{ {
FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileName
FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-FileNameLength
@ -79,7 +71,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
} get-slots >r memory>u16-string path+ r> parse-action swap ; } get-slots >r memory>u16-string path+ r> parse-action swap ;
: (changed-files) ( directory buffer -- ) : (changed-files) ( directory buffer -- )
2dup changed-file namespace [ append ] change-at 2dup changed-file namespace [ swap add ] change-at
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
[ 3drop ] [ swap <displaced-alien> (changed-files) ] if ; [ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;

2
extra/irc/irc.factor
View File

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

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

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

5
extra/lint/lint.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 macros math namespaces prettyprint quotations sequences
vectors vocabs words ; vectors vocabs words html.elements slots.private tar ;
USING: html.elements slots.private tar ;
IN: lint IN: lint
SYMBOL: def-hash SYMBOL: def-hash

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

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

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

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences 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 IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-non-terminal symbol ;

3
extra/peg/peg.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle 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 IN: peg
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;

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

@ -1,6 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer. ! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17 ! 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. ! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel math math.parser namespaces sequences sorting splitting USING: io.files kernel math math.parser namespaces sequences sorting splitting
strings system vocabs ; strings system vocabs ascii ;
IN: project-euler.022 IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22 ! 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays vectors namespaces math strings USING: kernel sequences arrays vectors namespaces math strings
combinators continuations quotations io assocs ; combinators continuations quotations io assocs ascii ;
IN: prolog IN: prolog

2
extra/regexp/regexp.factor
View File

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

2
extra/roman/roman.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.vectors namespaces 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 IN: roman
<PRIVATE <PRIVATE

2
extra/rot13/rot13.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Daniel Ehrenberg ! Copyright (C) 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: rot13
: rotate ( ch base -- ch ) tuck - 13 + 26 mod + ; : 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 USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors ; random sequences.private shuffle math.functions mirrors
USING: arrays math.parser sorting strings ; arrays math.parser sorting strings ascii ;
IN: sequences.lib IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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

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

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

@ -1,14 +1,14 @@
USING: math arrays sequences kernel splitting strings ; USING: math arrays sequences kernel splitting strings ;
IN: strings.lib 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 ) ! : >Upper ( str -- str )
dup empty? [ ! dup empty? [
unclip ch>upper 1string swap append ! unclip ch>upper 1string swap append
] unless ; ! ] unless ;
: >Upper-dashes ( str -- str ) ! : >Upper-dashes ( str -- str )
"-" split [ >Upper ] map "-" join ; ! "-" split [ >Upper ] map "-" join ;

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

@ -1,5 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces assocs.lib USING: kernel unicode.data sequences sequences.next namespaces
unicode.normalize math unicode.categories combinators assocs ; assocs.lib unicode.normalize math unicode.categories combinators
assocs ;
IN: unicode.case IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ; : 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 ; [ swap dot-over = over "ij" member? and swap , ] if ;
: lithuanian>upper ( string -- lower ) : 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 -- ? ) : mark-above? ( ch -- ? )
combining-class 230 = ; combining-class 230 = ;
@ -32,14 +33,14 @@ SYMBOL: locale ! Just casing locale, or overall?
dup , "IJ" member? swap mark-above? and [ dot-over , ] when ; dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
: lithuanian>lower ( string -- lower ) : lithuanian>lower ( string -- lower )
[ [ lithuanian-ch>lower ] each-next ] "" make* ; [ [ lithuanian-ch>lower ] each-next ] "" make ;
: turk-ch>upper ( ch -- ) : turk-ch>upper ( ch -- )
dup CHAR: i = dup CHAR: i =
[ drop CHAR: I , dot-over , ] [ , ] if ; [ drop CHAR: I , dot-over , ] [ , ] if ;
: turk>upper ( string -- upper-i ) : turk>upper ( string -- upper-i )
[ [ turk-ch>upper ] each ] "" make* ; [ [ turk-ch>upper ] each ] "" make ;
: turk-ch>lower ( ? next ch -- ? ) : turk-ch>lower ( ? next ch -- ? )
{ {
@ -52,7 +53,7 @@ SYMBOL: locale ! Just casing locale, or overall?
} cond ; } cond ;
: turk>lower ( string -- lower-i ) : 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 ? ) : word-boundary ( prev char -- new ? )
dup non-starter? [ drop dup ] when dup non-starter? [ drop dup ] when
@ -76,7 +77,7 @@ SYMBOL: locale ! Just casing locale, or overall?
[ -rot nip call , ] ?if [ -rot nip call , ] ?if
] 2keep ] 2keep
] each 2drop ] each 2drop
] "" make* ; inline ] "" make ; inline
: >lower ( string -- lower ) : >lower ( string -- lower )
i-dot? [ turk>lower ] when 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 ; math arrays ;
IN: unicode.normalize 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 ! Conjoining Jamo behavior
: hangul-base HEX: ac00 ; inline : 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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.responders webapps.file arrays io.launcher io http.server.responders webapps.file
sequences strings math.parser ; sequences strings math.parser unicode.case ;
IN: webapps.cgi IN: webapps.cgi
SYMBOL: cgi-root SYMBOL: cgi-root
@ -31,7 +31,7 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set "method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" 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 "User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set "Accept" header-param "HTTP_ACCEPT" set

6
extra/windows/kernel32/kernel32.factor
View File

@ -83,6 +83,12 @@ IN: windows.kernel32
: FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200 ; inline : FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200 ; inline
: FILE_NOTIFY_CHANGE_ALL HEX: 3ff ; inline : FILE_NOTIFY_CHANGE_ALL HEX: 3ff ; inline
: FILE_ACTION_ADDED 1 ; inline
: FILE_ACTION_REMOVED 2 ; inline
: FILE_ACTION_MODIFIED 3 ; inline
: FILE_ACTION_RENAMED_OLD_NAME 4 ; inline
: FILE_ACTION_RENAMED_NEW_NAME 5 ; inline
C-STRUCT: FILE_NOTIFY_INFORMATION C-STRUCT: FILE_NOTIFY_INFORMATION
{ "DWORD" "NextEntryOffset" } { "DWORD" "NextEntryOffset" }
{ "DWORD" "Action" } { "DWORD" "Action" }

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes USING: xml.errors xml.data xml.utilities xml.char-classes
xml.entities kernel state-parser kernel namespaces strings math 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 IN: xml.tokenize
! XML namespace processing: ns = namespace ! 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 USING: io io.streams.string io.files kernel math namespaces
prettyprint sequences arrays generic strings vectors prettyprint sequences arrays generic strings vectors
xml.char-classes xml.data xml.errors xml.tokenize xml.writer 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 IN: xml
! -- Overall parser with data tree ! -- 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 IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap ! 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 USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib 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 ! 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 USING: xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize regexp ; sequences vectors assocs strings memoize regexp unicode.case ;
IN: xmode.rules IN: xmode.rules
TUPLE: string-matcher string ignore-case? ; 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))) switch(untag_header(get(pointer)))
{ {
/* these objects do not refer to other objects at all */ /* these objects do not refer to other objects at all */
case STRING_TYPE:
case FLOAT_TYPE: case FLOAT_TYPE:
case BYTE_ARRAY_TYPE: case BYTE_ARRAY_TYPE:
case BIT_ARRAY_TYPE: case BIT_ARRAY_TYPE:
@ -522,6 +521,8 @@ CELL binary_payload_start(CELL pointer)
return CELLS * 2; return CELLS * 2;
case QUOTATION_TYPE: case QUOTATION_TYPE:
return sizeof(F_QUOTATION) - CELLS * 2; return sizeof(F_QUOTATION) - CELLS * 2;
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */ /* everything else consists entirely of pointers */
default: default:
return unaligned_object_size(pointer); return unaligned_object_size(pointer);

7
vm/os-netbsd.c Normal file → Executable file
View File

@ -1,6 +1,11 @@
#include "master.h" #include "master.h"
extern int main();
const char *vm_executable_path(void) const char *vm_executable_path(void)
{ {
return NULL; static Dl_info info = {0};
if (!info.dli_fname)
dladdr(main, &info);
return info.dli_fname;
} }

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) void set_string_nth(F_STRING* string, CELL index, CELL value)
{ {
bput(SREF(string,index),value & 0xff); bput(SREF(string,index),value & 0xff);
F_BYTE_ARRAY *aux;
if(string->aux == F) if(string->aux == F)
{ {
if(value <= 0xff) if(value <= 0xff)
return; return;
else else
{ {
string->aux = tag_object(allot_byte_array( REGISTER_UNTAGGED(string);
aux = allot_byte_array(
untag_fixnum_fast(string->length) 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); 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->length = tag_fixnum(capacity);
string->hashcode = F; string->hashcode = F;
string->aux = F; string->aux = F;
set_string_nth(string,capacity,0); set_string_nth(string,capacity,0);
return string; return string;
} }
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{ {
if(fill == 0) 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 else
{ {
CELL i; CELL i;
for(i = start; i < capacity; i++) for(i = start; i < capacity; i++)
{
REGISTER_UNTAGGED(string);
set_string_nth(string,i,fill); 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 *allot_string(CELL capacity, CELL fill)
{ {
F_STRING* string = allot_string_internal(capacity); F_STRING* string = allot_string_internal(capacity);
REGISTER_UNTAGGED(string);
fill_string(string,0,capacity,fill); fill_string(string,0,capacity,fill);
UNREGISTER_UNTAGGED(string);
return string; return string;
} }
@ -506,7 +531,23 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
UNREGISTER_UNTAGGED(string); UNREGISTER_UNTAGGED(string);
memcpy(new_string + 1,string + 1,to_copy); 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); fill_string(new_string,to_copy,capacity,fill);
UNREGISTER_UNTAGGED(string);
return new_string; return new_string;
} }
@ -529,7 +570,9 @@ DEFINE_PRIMITIVE(resize_string)
CELL i; \ CELL i; \
for(i = 0; i < length; i++) \ for(i = 0; i < length; i++) \
{ \ { \
REGISTER_UNTAGGED(s); \
set_string_nth(s,i,(utype)*string); \ set_string_nth(s,i,(utype)*string); \
UNREGISTER_UNTAGGED(s); \
string++; \ string++; \
} \ } \
return s; \ return s; \
@ -552,6 +595,7 @@ DEFINE_PRIMITIVE(resize_string)
MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16) MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)
bool check_string(F_STRING *s, CELL max) 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; return array->capacity >> TAG_BITS;
} }
#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index) #define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index) #define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
INLINE F_STRING* untag_string(CELL tagged) INLINE F_STRING* untag_string(CELL tagged)
{ {