CC = gcc
# On FreeBSD, to use SDL and other libc_r libs:
-CFLAGS = -Os -g -Wall -pthread -export-dynamic
+CFLAGS = -g -Wall -pthread -export-dynamic
# On PowerPC G5:
# CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3
# On Pentium 4:
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)\r
\r
+- profiler is inaccurate: wrong word on cs\r
- buffer change handler in sidekick is screwed\r
- dec> bin> oct> hex> throw errors\r
- parse-number doesn't\r
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: alien
+USE: compiler
+USE: lists
+USE: namespaces
+USE: stack
+
+: UNBOX ( name -- )
+ #! Move top of datastack to C stack.
+ dlsym-self CALL drop
+ EAX PUSH-R ;
+
+: BOX ( name -- )
+ #! Move EAX to datastack.
+ 24 ESP R-I
+ EAX PUSH-R
+ dlsym-self CALL drop
+ 28 ESP R+I ;
+
+: PARAMETERS ( list -- )
+ #! Generate code for boxing a list of C types.
+ [ c-type [ "unboxer" get ] bind UNBOX ] each ;
+
+: RETURNS ( type -- )
+ c-type [ "boxer" get ] bind BOX ;
--- /dev/null
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: alien
+USE: combinators
+USE: compiler
+USE: errors
+USE: lists
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: words
+
+! Some code for interfacing with C structures.
+
+: <c-type> ( -- type )
+ <namespace> [
+ [ "No setter" throw ] "setter" set
+ [ "No getter" throw ] "getter" set
+ "no boxer" "boxer" set
+ "no unboxer" "unboxer" set
+ 0 "width" set
+ ] extend ;
+
+: c-types ( -- ns )
+ global [ "c-types" get ] bind ;
+
+: c-type ( name -- type )
+ global [
+ dup "c-types" get get* dup [
+ nip
+ ] [
+ drop "No such C type: " swap cat2 throw
+ ] ifte
+ ] bind ;
+
+: define-c-type ( quot name -- )
+ c-types [ >r <c-type> swap extend r> set ] bind ;
+
+: define-getter ( offset type name -- )
+ #! Define a word with stack effect ( alien -- obj ) in the
+ #! current 'in' vocabulary.
+ "in" get create >r
+ [ "getter" get ] bind cons r> swap define-compound ;
+
+: define-setter ( offset type name -- )
+ #! Define a word with stack effect ( obj alien -- ) in the
+ #! current 'in' vocabulary.
+ "set-" swap cat2 "in" get create >r
+ [ "setter" get ] bind cons r> swap define-compound ;
+
+: define-field ( offset spec -- offset )
+ unswons >r c-type dup >r [ "width" get ] bind align r> r>
+ "struct-name" get swap "-" swap cat3
+ ( offset type name -- )
+ 3dup define-getter 3dup define-setter
+ drop [ "width" get ] bind + ;
+
+: define-constructor ( len -- )
+ [ <alien> ] cons
+ <% "<" % "struct-name" get % ">" % %> "in" get create swap
+ define-compound ;
+
+: define-struct-type ( len -- )
+ #! For example, if len is 32, make a C type with getter:
+ #! [ 32 >r alien-cell r> <alien> ] cons
+ #! The setter just throws an error for now.
+ [
+ [ >r alien-cell r> <alien> ] cons "getter" set
+ "unbox_alien" "unboxer" set
+ cell "width" set
+ ] "struct-name" get "*" cat2 define-c-type ;
+
+: define-struct ( spec name -- )
+ #! Define a set of words for working with a C structure
+ #! alien.
+ [
+ "struct-name" set
+ 0 swap [ define-field ] each
+ dup define-constructor
+ define-struct-type
+ ] with-scope ;
+
+global [ <namespace> "c-types" set ] bind
+
+[
+ [ alien-cell ] "getter" set
+ [ set-alien-cell ] "setter" set
+ cell "width" set
+ "does_not_exist" "boxer" set
+ "unbox_alien" "unboxer" set
+] "void*" define-c-type
+
+[
+ [ alien-4 ] "getter" set
+ [ set-alien-4 ] "setter" set
+ 4 "width" set
+ "box_integer" "boxer" set
+ "unbox_integer" "unboxer" set
+] "int" define-c-type
+
+[
+ [ alien-2 ] "getter" set
+ [ set-alien-2 ] "setter" set
+ 2 "width" set
+ "box_integer" "boxer" set
+ "unbox_integer" "unboxer" set
+] "short" define-c-type
+
+[
+ [ alien-1 ] "getter" set
+ [ set-alien-1 ] "setter" set
+ 1 "width" set
+ "box_integer" "boxer" set
+ "unbox_integer" "unboxer" set
+] "char" define-c-type
+
+[
+ [ alien-4 ] "getter" set
+ [ set-alien-4 ] "setter" set
+ cell "width" set
+ "box_c_string" "boxer" set
+ "unbox_c_string" "unboxer" set
+] "char*" define-c-type
compiled-offset literal-table + set-compiled-offset ;
: compile-aligned ( n -- )
- dup compiled-offset mod dup 0 = [
- 2drop
- ] [
- - compiled-offset + set-compiled-offset
- ] ifte ;
+ compiled-offset swap align set-compiled-offset ;
: intern-literal ( obj -- lit# )
address-of
compile-cell
] ifte ;
-: LITERAL ( cell -- )
- #! Push literal on data stack.
- #! Assume that it is ok to clobber EAX without saving.
- DATASTACK EAX [I]>R
- EAX I>[R]
- 4 DATASTACK I+[I] ;
-
-: [LITERAL] ( cell -- )
- #! Push complex literal on data stack by following an
- #! indirect pointer.
- ECX PUSH-R
- ( cell -- ) ECX [I]>R
- DATASTACK EAX [I]>R
- ECX EAX R>[R]
- 4 DATASTACK I+[I]
- ECX POP-R ;
-
-: PUSH-DS ( -- )
- #! Push contents of EAX onto datastack.
- ECX PUSH-R
- DATASTACK ECX [I]>R
- EAX ECX R>[R]
- 4 DATASTACK I+[I]
- ECX POP-R ;
-
-: POP-DS ( -- )
- #! Pop datastack, store pointer to datastack top in EAX.
- DATASTACK EAX [I]>R
- 4 EAX R-I
- EAX DATASTACK R>[I] ;
-
: fixup ( addr where -- )
#! Encode a relative offset to addr from where at where.
#! Add 4 because addr is relative to *after* insn.
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: compiler
+
+: LITERAL ( cell -- )
+ #! Push literal on data stack.
+ #! Assume that it is ok to clobber EAX without saving.
+ DATASTACK EAX [I]>R
+ EAX I>[R]
+ 4 DATASTACK I+[I] ;
+
+: [LITERAL] ( cell -- )
+ #! Push complex literal on data stack by following an
+ #! indirect pointer.
+ ECX PUSH-R
+ ( cell -- ) ECX [I]>R
+ DATASTACK EAX [I]>R
+ ECX EAX R>[R]
+ 4 DATASTACK I+[I]
+ ECX POP-R ;
+
+: PUSH-DS ( -- )
+ #! Push contents of EAX onto datastack.
+ ECX PUSH-R
+ DATASTACK ECX [I]>R
+ EAX ECX R>[R]
+ 4 DATASTACK I+[I]
+ ECX POP-R ;
+
+: POP-DS ( -- )
+ #! Pop datastack, store pointer to datastack top in EAX.
+ DATASTACK EAX [I]>R
+ 4 EAX R-I
+ EAX DATASTACK R>[I] ;
DEFER: set-alien-cell
DEFER: alien-4
DEFER: set-alien-4
+DEFER: alien-2
+DEFER: set-alien-2
DEFER: alien-1
DEFER: set-alien-1
set-alien-cell
alien-4
set-alien-4
+ alien-2
+ set-alien-2
alien-1
set-alien-1
] [
: polar> ( abs arg -- z )
cis * ; inline
+
+: align ( offset width -- offset )
+ 2dup mod dup 0 = [ 2drop ] [ - + ] ifte ;
"/library/compiler/assembler.factor"
"/library/compiler/assembly-x86.factor"
+ "/library/compiler/compiler-macros.factor"
"/library/compiler/compiler.factor"
"/library/compiler/words.factor"
+ "/library/compiler/alien-types.factor"
+ "/library/compiler/alien-macros.factor"
"/library/platform/native/primitives.factor"
[ set-alien-cell | " n alien off -- " ]
[ alien-4 | " alien off -- n " ]
[ set-alien-4 | " n alien off -- " ]
+ [ alien-2 | " alien off -- n " ]
+ [ set-alien-2 | " n alien off -- " ]
[ alien-1 | " alien off -- n " ]
[ set-alien-1 | " n alien off -- " ]
] [
USE: strings
USE: test
USE: vectors
+USE: lists
! Various things that broke CFactor at various times.
! This should run without issue (and tests nothing useful)
10 [ [ -1000000 <vector> ] [ drop ] catch ] times
10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times
+
+! Make sure various type checks don't run into header untagging
+! problems etc.
+
+! Lotype -vs- lotype
+[ ] [ [ 4 car ] [ drop ] catch ] unit-test
+
+! Lotype -vs- hitype
+[ ] [ [ 4 vector-length ] [ drop ] catch ] unit-test
+[ ] [ [ [ 4 3 ] vector-length ] [ drop ] catch ] unit-test
+
+! Hitype -vs- lotype
+[ ] [ [ "hello" car ] [ drop ] catch ] unit-test
+
+! Hitype -vs- hitype
+[ ] [ [ "hello" vector-length ] [ drop ] catch ] unit-test
+
+! f -vs- lotype
+[ ] [ [ f car ] [ drop ] catch ] unit-test
+
+! f -vs- hitype
+[ ] [ [ f vector-length ] [ drop ] catch ] unit-test
-1 over shift swap -1 >bignum swap shift = and
] each
] unit-test
+
+[ 12 ] [ 11 4 align ] unit-test
+[ 12 ] [ 12 4 align ] unit-test
+[ 12 ] [ 10 2 align ] unit-test
+[ 14 ] [ 13 2 align ] unit-test
+[ 11 ] [ 11 1 align ] unit-test
#endif
}
+ALIEN* unbox_alien(void)
+{
+ return untag_alien(dpop())->ptr;
+}
+
INLINE CELL alien_pointer(void)
{
FIXNUM offset = unbox_integer();
#endif
}
+void primitive_alien_2(void)
+{
+#ifdef FFI
+ CELL ptr = alien_pointer();
+ box_integer(*(CHAR*)ptr);
+#else
+ general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_set_alien_2(void)
+{
+#ifdef FFI
+ CELL ptr = alien_pointer();
+ CELL value = unbox_integer();
+ *(CHAR*)ptr = value;
+#else
+ general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
void primitive_alien_1(void)
{
#ifdef FFI
void primitive_dlsym_self(void);
void primitive_dlclose(void);
void primitive_alien(void);
+ALIEN* unbox_alien(void);
void primitive_alien_cell(void);
void primitive_set_alien_cell(void);
void primitive_alien_4(void);
void primitive_set_alien_4(void);
+void primitive_alien_2(void);
+void primitive_set_alien_2(void);
void primitive_alien_1(void);
void primitive_set_alien_1(void);
primitive_set_alien_cell,
primitive_alien_4,
primitive_set_alien_4,
+ primitive_alien_2,
+ primitive_set_alien_2,
primitive_alien_1,
primitive_set_alien_1
};
extern XT primitives[];
-#define PRIMITIVE_COUNT 188
+#define PRIMITIVE_COUNT 190
CELL primitive_to_xt(CELL primitive);
{
if(type < HEADER_TYPE)
{
- if(TAG(tagged) != type)
- type_error(type,tagged);
+ if(TAG(tagged) == type)
+ return;
}
- else if(object_type(tagged) != type)
- type_error(type,tagged);
+ else if(tagged == F)
+ {
+ if(type == F_TYPE)
+ return;
+ }
+ else if(TAG(tagged) == OBJECT_TYPE
+ && object_type(tagged) == type)
+ {
+ return;
+ }
+
+ type_error(type,tagged);
}
void* allot_object(CELL type, CELL length);
projects / factor.git / commitdiff