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

Remove cruddy string encoding/decoding code from VM

db4
Slava Pestov 2009-05-02 13:45:38 -05:00
parent 7c12b5578f
commit a63ad6a7a5
69 changed files with 380 additions and 523 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
basis/alien/arrays/arrays.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel namespaces fry libc cpu.architecture ;
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 io.encodings.utf16n ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -38,3 +39,61 @@ M: value-type c-type-getter
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{ "char*" utf16n } "wchar_t*" typedef

36
basis/alien/c-types/c-types-docs.factor
View File

@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax
debugger destructors ;
byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -114,6 +114,38 @@ HELP: define-out
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
{ string>alien alien>string malloc-string } related-words
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
$nl

16
basis/alien/c-types/c-types.factor
View File

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations fry classes ;
math.parser cpu.architecture alien alien.accessors alien.strings
quotations layouts system compiler.units io io.files
io.encodings.binary io.streams.memory accessors combinators effects
continuations fry classes ;
IN: alien.c-types
DEFER: <int>
@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ;

6
basis/alien/libraries/libraries.factor
View File

@ -1,8 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien assocs io.backend kernel namespaces ;
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
SYMBOL: libraries
libraries [ H{ } clone ] initialize

52
basis/alien/strings/strings-docs.factor
View File

@ -1,52 +0,0 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger io.encodings.string sequences ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ABOUT: "c-strings"

109
basis/alien/strings/strings.factor
View File

@ -1,109 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.encodings.utf8 io.streams.byte-array io.streams.memory system
alien strings cpu.architecture fry vocabs.loader combinators ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
HOOK: alien>native-string os ( alien -- string )
HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{
{ [ os windows? ] [ "alien.strings.windows" require ] }
{ [ os unix? ] [ "alien.strings.unix" require ] }
} cond

1
basis/alien/strings/unix/summary.txt
View File

@ -1 +0,0 @@
Default string encoding on Unix

8
basis/alien/strings/unix/unix.factor
View File

@ -1,8 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings io.encodings.utf8 system ;
IN: alien.strings.unix
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;

1
basis/alien/strings/windows/summary.txt
View File

@ -1 +0,0 @@
Default string encoding on Windows

1
basis/alien/strings/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

13
basis/alien/strings/windows/windows.factor
View File

@ -1,13 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings alien.c-types io.encodings.utf8
io.encodings.utf16n system ;
IN: alien.strings.windows
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
{ "char*" utf16n } "wchar_t*" typedef

1
basis/bootstrap/stage2.factor
View File

@ -65,7 +65,6 @@ SYMBOL: bootstrap-time
"stage2: deployment mode" print
] [
"debugger" require
"alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require

6
basis/command-line/command-line.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
io.files io.pathnames kernel kernel.private namespaces parser
sequences strings system splitting vocabs.loader ;
sequences strings system splitting vocabs.loader alien.strings ;
IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift ;
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless

4
basis/compiler/tests/simple.factor
View File

@ -60,8 +60,8 @@ IN: compiler.tests.simple
! Make sure error reporting works
[ [ dup ] compile-call ] must-fail
[ [ drop ] compile-call ] must-fail
! [ [ dup ] compile-call ] must-fail
! [ [ drop ] compile-call ] must-fail
! Regression

24
basis/debugger/debugger.factor
View File

@ -1,14 +1,13 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces make prettyprint prettyprint.config
sequences assocs sequences.private strings io.styles
io.pathnames vectors words system splitting math.parser
classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units
generic.standard generic.single vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer
USING: slots arrays definitions generic hashtables summary io kernel
math namespaces make prettyprint prettyprint.config sequences assocs
sequences.private strings io.styles io.pathnames vectors words system
splitting math.parser classes.mixin classes.tuple continuations
continuations.private combinators generic.math classes.builtin classes
compiler.units generic.standard generic.single vocabs init
kernel.private io.encodings accessors math.order destructors
source-files parser classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger
@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
M: object error. . ;
M: object error-help drop f ;
M: tuple error-help class ;
@ -77,7 +77,7 @@ M: string error. print ;
"Object did not survive image save/load: " write third . ;
: io-error. ( error -- )
"I/O error: " write third print ;
"I/O error #" write third . ;
: type-check-error. ( obj -- )
"Type check error" print
@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- )
"Cannot convert to C string: " write third . ;
: ffi-error. ( obj -- )
"FFI: " write
dup third [ write ": " write ] when*
fourth print ;
"FFI error" print drop ;
: heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ;

5
basis/io/encodings/iana/iana.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs
splitting sequences io namespaces sets
io.encodings.ascii io.encodings.utf8 ;
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
IN: io.encodings.iana
<PRIVATE
@ -55,3 +55,6 @@ e>n-table [ initial-e>n ] initialize
] [ swap e>n-table get-global set-at ] 2bi ;
ascii "ANSI_X3.4-1968" register-encoding
utf16be "UTF-16BE" register-encoding
utf16le "UTF-16LE" register-encoding
utf16 "UTF-16" register-encoding

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser math.private strings math
USING: kernel peg peg.ebnf math.parser math.parser.private strings math
math.functions sequences arrays vectors hashtables assocs
prettyprint json ;
IN: json.reader

14
basis/prettyprint/backend/backend.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays generic hashtables io assocs
kernel math namespaces make sequences strings sbufs vectors
USING: accessors arrays byte-arrays byte-vectors generic hashtables io
assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
quotations io io.pathnames io.styles math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators colors ;
quotations io io.pathnames io.styles math.parser effects classes.tuple
math.order classes.tuple.private classes combinators colors ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -165,6 +164,7 @@ M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
@ -173,6 +173,7 @@ M: callstack pprint-delims drop \ CS{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
@ -202,6 +203,7 @@ M: object pprint-object ( obj -- )
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;

38
basis/stack-checker/known-words/known-words.factor
View File

@ -1,16 +1,16 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays
classes sequences.private continuations.private effects generic
hashtables hashtables.private io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
USING: fry accessors alien alien.accessors arrays byte-arrays classes
sequences.private continuations.private effects generic hashtables
hashtables.private io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private
math.parser.private memory memory.private namespaces
namespaces.private parser quotations quotations.private sbufs
sbufs.private sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
assocs summary compiler.units system.private
combinators combinators.short-circuit locals locals.backend locals.types
classes.tuple.private vectors vectors.private words definitions assocs
summary compiler.units system.private combinators
combinators.short-circuit locals locals.backend locals.types
quotations.private combinators.private stack-checker.values
generic.single generic.single.private
alien.libraries
@ -290,11 +290,11 @@ M: object infer-call*
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
\ string>float { string } { float } define-primitive
\ string>float make-foldable
\ (string>float) { byte-array } { float } define-primitive
\ (string>float) make-foldable
\ float>string { float } { string } define-primitive
\ float>string make-foldable
\ (float>string) { float } { byte-array } define-primitive
\ (float>string) make-foldable
\ float>bits { real } { integer } define-primitive
\ float>bits make-foldable
@ -465,9 +465,9 @@ M: object infer-call*
\ gc-stats { } { array } define-primitive
\ save-image { string } { } define-primitive
\ (save-image) { byte-array } { } define-primitive
\ save-image-and-exit { string } { } define-primitive
\ (save-image-and-exit) { byte-array } { } define-primitive
\ data-room { } { integer integer array } define-primitive
\ data-room make-flushable
@ -481,9 +481,9 @@ M: object infer-call*
\ tag { object } { fixnum } define-primitive
\ tag make-foldable
\ dlopen { string } { dll } define-primitive
\ (dlopen) { byte-array } { dll } define-primitive
\ dlsym { string object } { c-ptr } define-primitive
\ (dlsym) { byte-array object } { c-ptr } define-primitive
\ dlclose { dll } { } define-primitive
@ -598,7 +598,7 @@ M: object infer-call*
\ die { } { } define-primitive
\ fopen { string string } { alien } define-primitive
\ (fopen) { byte-array byte-array } { alien } define-primitive
\ fgetc { alien } { object } define-primitive

20
core/alien/strings/strings-docs.factor Normal file
View File

@ -0,0 +1,20 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger io.encodings.string sequences ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
ABOUT: "c-strings"

0
basis/alien/strings/strings-tests.factor → core/alien/strings/strings-tests.factor
View File

61
core/alien/strings/strings.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel kernel.private accessors math
alien.accessors byte-arrays io io.encodings io.encodings.utf8
io.encodings.utf16n io.streams.byte-array io.streams.memory system
system.private alien strings combinators namespaces init ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
HOOK: alien>native-string os ( alien -- string )
HOOK: native-string>alien os ( string -- alien )
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
[
8 getenv utf8 alien>string string>cpu \ cpu set-global
9 getenv utf8 alien>string string>os \ os set-global
] "alien.strings" add-init-hook

0
basis/alien/strings/summary.txt → core/alien/strings/summary.txt
View File

68
core/bootstrap/primitives.factor
View File

@ -82,8 +82,10 @@ bootstrapping? on
"kernel"
"kernel.private"
"math"
"math.parser.private"
"math.private"
"memory"
"memory.private"
"quotations"
"quotations.private"
"sbufs"
@ -366,8 +368,8 @@ tuple
{ "float>bignum" "math.private" (( x -- y )) }
{ "fixnum>float" "math.private" (( x -- y )) }
{ "bignum>float" "math.private" (( x -- y )) }
{ "string>float" "math.private" (( str -- n/f )) }
{ "float>string" "math.private" (( n -- str )) }
{ "(string>float)" "math.parser.private" (( str -- n/f )) }
{ "(float>string)" "math.parser.private" (( n -- str )) }
{ "float>bits" "math" (( x -- n )) }
{ "double>bits" "math" (( x -- n )) }
{ "bits>float" "math" (( n -- x )) }
@ -414,8 +416,8 @@ tuple
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "gc" "memory" (( -- )) }
{ "gc-stats" "memory" f }
{ "save-image" "memory" (( path -- )) }
{ "save-image-and-exit" "memory" (( path -- )) }
{ "(save-image)" "memory.private" (( path -- )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "retainstack" "kernel" (( -- rs )) }
{ "callstack" "kernel" (( -- cs )) }
@ -427,38 +429,38 @@ tuple
{ "code-room" "memory" (( -- code-free code-total )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "dlopen" "alien.libraries" (( path -- dll )) }
{ "dlsym" "alien.libraries" (( name dll -- alien )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
{ "(dlsym)" "alien.libraries" (( name dll -- alien )) }
{ "dlclose" "alien.libraries" (( dll -- )) }
{ "<byte-array>" "byte-arrays" (( n -- byte-array )) }
{ "(byte-array)" "byte-arrays" (( n -- byte-array )) }
{ "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
{ "alien-signed-cell" "alien.accessors" f }
{ "set-alien-signed-cell" "alien.accessors" f }
{ "alien-unsigned-cell" "alien.accessors" f }
{ "set-alien-unsigned-cell" "alien.accessors" f }
{ "alien-signed-8" "alien.accessors" f }
{ "set-alien-signed-8" "alien.accessors" f }
{ "alien-unsigned-8" "alien.accessors" f }
{ "set-alien-unsigned-8" "alien.accessors" f }
{ "alien-signed-4" "alien.accessors" f }
{ "set-alien-signed-4" "alien.accessors" f }
{ "alien-unsigned-4" "alien.accessors" f }
{ "set-alien-unsigned-4" "alien.accessors" f }
{ "alien-signed-2" "alien.accessors" f }
{ "set-alien-signed-2" "alien.accessors" f }
{ "alien-unsigned-2" "alien.accessors" f }
{ "set-alien-unsigned-2" "alien.accessors" f }
{ "alien-signed-1" "alien.accessors" f }
{ "set-alien-signed-1" "alien.accessors" f }
{ "alien-unsigned-1" "alien.accessors" f }
{ "set-alien-unsigned-1" "alien.accessors" f }
{ "alien-float" "alien.accessors" f }
{ "set-alien-float" "alien.accessors" f }
{ "alien-double" "alien.accessors" f }
{ "set-alien-double" "alien.accessors" f }
{ "alien-cell" "alien.accessors" f }
{ "set-alien-cell" "alien.accessors" f }
{ "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-float" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-float" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-double" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-double" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-cell" "alien.accessors" (( c-ptr n -- value )) }
{ "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-address" "alien" (( c-ptr -- addr )) }
{ "set-slot" "slots.private" (( value obj n -- )) }
{ "string-nth" "strings.private" (( n string -- ch )) }
@ -472,7 +474,7 @@ tuple
{ "end-scan" "memory" (( -- )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
{ "fopen" "io.streams.c" (( path mode -- alien )) }
{ "(fopen)" "io.streams.c" (( path mode -- alien )) }
{ "fgetc" "io.streams.c" (( alien -- ch/f )) }
{ "fread" "io.streams.c" (( n alien -- str/f )) }
{ "fputc" "io.streams.c" (( ch alien -- )) }

1
core/bootstrap/syntax.factor
View File

@ -16,6 +16,7 @@ IN: bootstrap.syntax
"<PRIVATE"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"

0
basis/byte-vectors/byte-vectors-docs.factor → core/byte-vectors/byte-vectors-docs.factor
View File

0
basis/byte-vectors/byte-vectors-tests.factor → core/byte-vectors/byte-vectors-tests.factor
View File

9
basis/byte-vectors/byte-vectors.factor → core/byte-vectors/byte-vectors.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays accessors parser
prettyprint.custom ;
sequences.private growable byte-arrays accessors ;
IN: byte-vectors
TUPLE: byte-vector
@ -42,10 +41,4 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ;
SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: byte-vector >pprint-sequence ;
INSTANCE: byte-vector growable

0
basis/byte-vectors/summary.txt → core/byte-vectors/summary.txt
View File

0
basis/byte-vectors/tags.txt → core/byte-vectors/tags.txt
View File

9
core/classes/algebra/algebra-tests.factor
View File

@ -305,7 +305,16 @@ SINGLETON: sc
[ sa ] [ sa { sa sb sc } min-class ] unit-test
[ f ] [ sa sb classes-intersect? ] unit-test
[ +lt+ ] [ integer sequence class<=> ] unit-test
[ +lt+ ] [ sequence object class<=> ] unit-test
[ +gt+ ] [ object sequence class<=> ] unit-test
[ +eq+ ] [ integer integer class<=> ] unit-test
! Limitations:
! UNION: u1 sa sb ;
! UNION: u2 sc ;
! [ f ] [ u1 u2 classes-intersect? ] unit-test

0
basis/io/encodings/utf16/authors.txt → core/io/encodings/utf16/authors.txt
View File

0
basis/io/encodings/utf16/summary.txt → core/io/encodings/utf16/summary.txt
View File

0
basis/io/encodings/utf16/utf16-docs.factor → core/io/encodings/utf16/utf16-docs.factor
View File

0
basis/io/encodings/utf16/utf16-tests.factor → core/io/encodings/utf16/utf16-tests.factor
View File

8
basis/io/encodings/utf16/utf16.factor → core/io/encodings/utf16/utf16.factor
View File

@ -1,21 +1,15 @@
! Copyright (C) 2006, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting io byte-arrays io.encodings.iana ;
io.encodings combinators splitting io byte-arrays ;
IN: io.encodings.utf16
SINGLETON: utf16be
utf16be "UTF-16BE" register-encoding
SINGLETON: utf16le
utf16le "UTF-16LE" register-encoding
SINGLETON: utf16
utf16 "UTF-16" register-encoding
ERROR: missing-bom ;
<PRIVATE

0
basis/io/encodings/utf16n/authors.txt → core/io/encodings/utf16n/authors.txt
View File

0
basis/io/encodings/utf16n/summary.txt → core/io/encodings/utf16n/summary.txt
View File

0
basis/io/encodings/utf16n/utf16n-docs.factor → core/io/encodings/utf16n/utf16n-docs.factor
View File

0
basis/io/encodings/utf16n/utf16n-tests.factor → core/io/encodings/utf16n/utf16n-tests.factor
View File

4
basis/io/encodings/utf16n/utf16n.factor → core/io/encodings/utf16n/utf16n.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
USING: io.encodings io.encodings.utf16 kernel alien.accessors ;
IN: io.encodings.utf16n
! Native-order UTF-16
@ -8,7 +8,7 @@ IN: io.encodings.utf16n
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
B{ 1 0 0 0 } 0 alien-unsigned-4 1 = utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;

12
core/io/files/files.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences init namespaces system io
io.backend io.pathnames io.encodings io.files.private ;
io.backend io.pathnames io.encodings io.files.private
alien.strings ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -40,7 +41,8 @@ HOOK: (file-appender) io-backend ( path -- stream )
: with-file-appender ( path encoding quot -- )
[ <file-appender> ] dip with-output-stream ; inline
: exists? ( path -- ? ) normalize-path (exists?) ;
: exists? ( path -- ? )
normalize-path native-string>alien (exists?) ;
! Current directory
<PRIVATE
@ -55,7 +57,7 @@ PRIVATE>
[
cwd current-directory set-global
13 getenv cwd prepend-path \ image set-global
14 getenv cwd prepend-path \ vm set-global
13 getenv alien>native-string cwd prepend-path \ image set-global
14 getenv alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-init-hook

0
basis/io/streams/byte-array/byte-array-docs.factor → core/io/streams/byte-array/byte-array-docs.factor
View File

0
basis/io/streams/byte-array/byte-array-tests.factor → core/io/streams/byte-array/byte-array-tests.factor
View File

4
basis/io/streams/byte-array/byte-array.factor → core/io/streams/byte-array/byte-array.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private accessors sequences.private
USING: byte-arrays byte-vectors kernel io.encodings sequences io
namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array

0
basis/io/streams/byte-array/summary.txt → core/io/streams/byte-array/summary.txt
View File

11
core/io/streams/c/c.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces make io io.encodings
sequences math generic threads.private classes io.backend
io.files continuations destructors byte-arrays accessors
combinators ;
USING: kernel kernel.private namespaces make io io.encodings sequences
math generic threads.private classes io.backend io.files
io.encodings.utf8 alien.strings continuations destructors byte-arrays
accessors combinators ;
IN: io.streams.c
TUPLE: c-stream handle disposed ;
@ -69,6 +69,9 @@ M: c-io-backend (init-stdio) init-c-stdio t ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
: fopen ( path mode -- handle )
[ utf8 string>alien ] bi@ (fopen) ;
M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;

8
basis/io/streams/memory/memory.factor → core/io/streams/memory/memory.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors alien alien.c-types alien.accessors math io ;
USING: kernel accessors alien alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
@ -13,9 +13,3 @@ M: memory-stream stream-element-type drop +byte+ ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;

0
basis/io/streams/memory/summary.txt → core/io/streams/memory/summary.txt
View File

2
core/math/parser/parser-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax math math.private prettyprint
USING: help.markup help.syntax math math.parser.private prettyprint
namespaces make strings ;
IN: math.parser

12
core/math/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences sequences.private
strings arrays combinators splitting math assocs make ;
strings arrays combinators splitting math assocs byte-arrays make ;
IN: math.parser
: digit> ( ch -- n )
@ -79,6 +79,9 @@ SYMBOL: negative?
string>natural
] if ; inline
: string>float ( str -- n/f )
>byte-array 0 suffix (string>float) ;
PRIVATE>
: base> ( str radix -- n/f )
@ -149,13 +152,18 @@ M: ratio >base
[ ".0" append ]
} cond ;
: float>string ( x -- str )
(float>string)
[ 0 = ] trim-tail >string
fix-float ;
M: float >base
drop {
{ [ dup fp-nan? ] [ drop "0/0." ] }
{ [ dup 1/0. = ] [ drop "1/0." ] }
{ [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ]
[ float>string ]
} cond ;
: number>string ( n -- str ) 10 >base ;

11
core/memory/memory.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences vectors arrays system math ;
USING: kernel continuations sequences vectors arrays system math
io.backend alien.strings memory.private ;
IN: memory
: (each-object) ( quot: ( obj -- ) -- )
@ -21,4 +22,10 @@ IN: memory
[ count-instances 100 + <vector> ] keep swap
[ [ push-if ] 2curry each-object ] keep >array ; inline
: save-image ( path -- )
normalize-path native-string>alien (save-image) ;
: save-image-and-exit ( path -- )
normalize-path native-string>alien (save-image) ;
: save ( -- ) image save-image ;

3
core/syntax/syntax.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays byte-arrays definitions generic
USING: accessors alien arrays byte-arrays byte-vectors definitions generic
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words words.symbol words.constant
words.alias quotations io assocs splitting classes.tuple
@ -98,6 +98,7 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-core-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
"T{" [ parse-tuple-literal parsed ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax

24
core/system/system.factor
View File

@ -1,29 +1,20 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
IN: system
SINGLETON: x86.32
SINGLETON: x86.64
SINGLETON: arm
SINGLETON: ppc
SINGLETONS: x86.32 x86.64 arm ppc ;
UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get-global ; foldable
SINGLETON: winnt
SINGLETON: wince
SINGLETONS: winnt wince ;
UNION: windows winnt wince ;
SINGLETON: freebsd
SINGLETON: netbsd
SINGLETON: openbsd
SINGLETON: solaris
SINGLETON: macosx
SINGLETON: linux
SINGLETONS: freebsd netbsd openbsd solaris macosx linux ;
SINGLETON: haiku
@ -62,11 +53,6 @@ PRIVATE>
: vm ( -- path ) \ vm get-global ;
[
8 getenv string>cpu \ cpu set-global
9 getenv string>os \ os set-global
] "system" add-init-hook
: embedded? ( -- ? ) 15 getenv ;
: millis ( -- ms ) micros 1000 /i ;

9
vmpp/alien.cpp
View File

@ -183,7 +183,8 @@ void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
/* open a native library and push a handle */
void primitive_dlopen(void)
{
gc_root<F_BYTE_ARRAY> path(tag_object(string_to_native_alien(untag_string(dpop()))));
gc_root<F_BYTE_ARRAY> path(dpop());
path.untag_check();
gc_root<F_DLL> dll(allot<F_DLL>(sizeof(F_DLL)));
dll->path = path.value();
ffi_dlopen(dll.untagged());
@ -194,7 +195,11 @@ void primitive_dlopen(void)
void primitive_dlsym(void)
{
gc_root<F_OBJECT> dll(dpop());
F_SYMBOL *sym = unbox_symbol_string();
gc_root<F_BYTE_ARRAY> name(dpop());
dll.untag_check();
name.untag_check();
F_CHAR *sym = (F_CHAR *)(name.untagged() + 1);
if(dll.value() == F)
box_alien(ffi_dlsym(NULL,sym));

4
vmpp/code_block.cpp
View File

@ -340,10 +340,6 @@ void *get_rel_symbol(F_ARRAY *literals, CELL index)
}
}
#ifdef FACTOR_DEBUG
print_obj(symbol); nl(); fflush(stdout);
#endif
return (void *)undefined_symbol;
}

8
vmpp/factor.cpp
View File

@ -132,10 +132,10 @@ void init_factor(F_PARAMETERS *p)
init_profiler();
userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
userenv[CPU_ENV] = allot_alien(F,(CELL)FACTOR_CPU_STRING);
userenv[OS_ENV] = allot_alien(F,(CELL)FACTOR_OS_STRING);
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
userenv[EXECUTABLE_ENV] = allot_alien(F,(CELL)p->executable_path);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
@ -156,7 +156,7 @@ void pass_args_to_factor(int argc, F_CHAR **argv)
int i;
for(i = 1; i < argc; i++)
args.add(tag_object(from_native_string(argv[i])));
args.add(allot_alien(F,(CELL)argv[i]));
args.trim();
userenv[ARGS_ENV] = args.array.value();

15
vmpp/image.cpp
View File

@ -132,7 +132,9 @@ void primitive_save_image(void)
/* do a full GC to push everything into tenured space */
gc();
save_image(unbox_native_string());
gc_root<F_BYTE_ARRAY> path(dpop());
path.untag_check();
save_image((F_CHAR *)(path.untagged() + 1));
}
void primitive_save_image_and_exit(void)
@ -140,9 +142,8 @@ void primitive_save_image_and_exit(void)
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
F_CHAR *path = unbox_native_string();
REGISTER_C_STRING(path);
gc_root<F_BYTE_ARRAY> path(dpop());
path.untag_check();
/* strip out userenv data which is set on startup anyway */
CELL i;
@ -157,10 +158,8 @@ void primitive_save_image_and_exit(void)
compact_code_heap();
performing_compaction = false;
UNREGISTER_C_STRING(F_CHAR,path);
/* Save the image */
if(save_image(path))
if(save_image((F_CHAR *)(path.untagged() + 1)))
exit(0);
else
exit(1);
@ -335,5 +334,5 @@ void load_image(F_PARAMETERS *p)
relocate_code();
/* Store image path name */
userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path));
userenv[IMAGE_ENV] = allot_alien(F,(CELL)p->image_path);
}

14
vmpp/io.cpp
View File

@ -25,20 +25,20 @@ void io_error(void)
return;
#endif
CELL error = tag_object(from_char_string(strerror(errno)));
general_error(ERROR_IO,error,F,NULL);
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
void primitive_fopen(void)
{
char *mode = unbox_char_string();
REGISTER_C_STRING(mode);
char *path = unbox_char_string();
UNREGISTER_C_STRING(char,mode);
gc_root<F_BYTE_ARRAY> mode(dpop());
gc_root<F_BYTE_ARRAY> path(dpop());
mode.untag_check();
path.untag_check();
for(;;)
{
FILE *file = fopen(path,mode);
FILE *file = fopen((char *)(path.untagged() + 1),
(char *)(mode.untagged() + 1));
if(file == NULL)
io_error();
else

27
vmpp/local_roots.hpp
View File

@ -1,6 +1,6 @@
/* If a runtime function needs to call another function which potentially
allocates memory, it must store any local variable references to Factor
objects on the root stack */
allocates memory, it must wrap any local variable references to Factor
objects in gc_root instances */
extern F_SEGMENT *gc_locals_region;
extern CELL gc_locals;
@ -27,28 +27,5 @@ extern CELL extra_roots;
DEFPUSHPOP(root_,extra_roots)
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
{
root_push(tag_object(objptr));
return true;
}
}
return false;
}
#define REGISTER_C_STRING(obj) \
bool obj##_root = root_push_alien((const char *)obj)
#define UNREGISTER_C_STRING(type,obj) \
if(obj##_root) obj = (type *)alien_offset(root_pop())
#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_bignum_fast(root_pop()))

25
vmpp/math.cpp
View File

@ -392,26 +392,23 @@ void primitive_bignum_to_float(void)
void primitive_str_to_float(void)
{
char *c_str, *end;
double f;
F_STRING *str = untag_string(dpeek());
CELL capacity = string_capacity(str);
F_BYTE_ARRAY *bytes = untag_byte_array(dpeek());
CELL capacity = array_capacity(bytes);
c_str = to_char_string(str,false);
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + capacity)
drepl(F);
else
char *c_str = (char *)(bytes + 1);
char *end = c_str;
double f = strtod(c_str,&end);
if(end == c_str + capacity - 1)
drepl(allot_float(f));
else
drepl(F);
}
void primitive_float_to_str(void)
{
char tmp[33];
snprintf(tmp,32,"%.16g",untag_float(dpop()));
tmp[32] = '\0';
box_char_string(tmp);
F_BYTE_ARRAY *array = allot_byte_array(33);
snprintf((char *)(array + 1),32,"%.16g",untag_float(dpop()));
dpush(tag_object(array));
}
#define POP_FLOATS(x,y) \

8
vmpp/os-unix.cpp
View File

@ -48,17 +48,15 @@ void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
void ffi_dlclose(F_DLL *dll)
{
if(dlclose(dll->dll))
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,NULL);
}
general_error(ERROR_FFI,F,F,NULL);
dll->dll = NULL;
}
void primitive_existsp(void)
{
struct stat sb;
box_boolean(stat(unbox_char_string(),&sb) >= 0);
char *path = (char *)(untag_byte_array(dpop()) + 1);
box_boolean(stat(path,&sb) >= 0);
}
F_SEGMENT *alloc_segment(CELL size)

3
vmpp/os-unix.hpp
View File

@ -11,10 +11,7 @@
typedef char F_CHAR;
typedef char F_SYMBOL;
#define from_native_string from_char_string
#define unbox_native_string unbox_char_string
#define string_to_native_alien(string) string_to_char_alien(string,true)
#define unbox_symbol_string unbox_char_string
#define STRING_LITERAL(string) string

3
vmpp/os-windows-ce.hpp
View File

@ -7,9 +7,6 @@
typedef wchar_t F_SYMBOL;
#define unbox_symbol_string unbox_u16_string
#define from_symbol_string from_u16_string
#define FACTOR_OS_STRING "wince"
#define FACTOR_DLL L"factor-ce.dll"
#define FACTOR_DLL_NAME "factor-ce.dll"

3
vmpp/os-windows-nt.hpp
View File

@ -9,9 +9,6 @@
typedef char F_SYMBOL;
#define unbox_symbol_string unbox_char_string
#define from_symbol_string from_char_string
#define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll"

2
vmpp/os-windows.cpp
View File

@ -90,7 +90,7 @@ const F_CHAR *vm_executable_path(void)
void primitive_existsp(void)
{
F_CHAR *path = unbox_u16_string();
F_CHAR *path = (F_CHAR *)(untag_byte_array(dpop()) + 1);
box_boolean(windows_stat(path));
}

2
vmpp/os-windows.hpp
View File

@ -7,8 +7,6 @@
typedef wchar_t F_CHAR;
#define from_native_string from_u16_string
#define unbox_native_string unbox_u16_string
#define string_to_native_alien(string) string_to_u16_alien(string,true)
#define STRING_LITERAL(string) L##string

89
vmpp/strings.cpp
View File

@ -157,95 +157,6 @@ void primitive_resize_string(void)
dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
#define MEMORY_TO_STRING(type,utype) \
F_STRING *memory_to_##type##_string(const type *string, CELL length) \
{ \
REGISTER_C_STRING(string); \
gc_root<F_STRING> s(allot_string_internal(length)); \
UNREGISTER_C_STRING(type,string); \
CELL i; \
for(i = 0; i < length; i++) \
{ \
set_string_nth(s.untagged(),i,(utype)*string); \
string++; \
} \
return s.untagged(); \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
CELL length = 0; \
const type *scan = str; \
while(*scan++) length++; \
return memory_to_##type##_string(str,length); \
} \
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
}
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)
bool check_string(F_STRING *s, CELL max)
{
CELL capacity = string_capacity(s);
CELL i;
for(i = 0; i < capacity; i++)
{
CELL ch = string_nth(s,i);
if(ch == 0 || ch >= ((CELL)1 << (max * 8)))
return false;
}
return true;
}
F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
{
return allot_byte_array((capacity + 1) * size);
}
#define STRING_TO_MEMORY(type) \
void type##_string_to_memory(F_STRING *s, type *string) \
{ \
CELL i; \
CELL capacity = string_capacity(s); \
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
void primitive_##type##_string_to_memory(void) \
{ \
type *address = (type *)unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s_, bool check) \
{ \
gc_root<F_STRING> s(s_); \
CELL capacity = string_capacity(s.untagged()); \
F_BYTE_ARRAY *_c_str; \
if(check && !check_string(s.untagged(),sizeof(type))) \
general_error(ERROR_C_STRING,s.value(),F,NULL); \
_c_str = allot_c_string(capacity,sizeof(type)); \
type *c_str = (type*)(_c_str + 1); \
type##_string_to_memory(s.untagged(),c_str); \
c_str[capacity] = 0; \
return _c_str; \
} \
type *to_##type##_string(F_STRING *s, bool check) \
{ \
return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *unbox_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
}
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
void primitive_string_nth(void)
{
F_STRING *string = untag_string_fast(dpop());

18
vmpp/strings.hpp
View File

@ -19,24 +19,6 @@ void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
void char_string_to_memory(F_STRING *s, char *string);
F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
DLLEXPORT char *unbox_char_string(void);
void u16_string_to_memory(F_STRING *s, u16 *string);
F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
DLLEXPORT u16 *unbox_u16_string(void);
/* String getters and setters */
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);