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

messing around with ffi, various other fixes

cvs
Slava Pestov 2005-03-29 04:45:13 +00:00
parent bbc7c97aa4
commit 41cd52316a
93 changed files with 568 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
TODO.FACTOR.txt
View File

@ -1,4 +1,3 @@
- word preview for parsing words
- set 'end' of artifacts/assets accurately
- faster layout
- faster repaint
@ -11,13 +10,13 @@
- make-image: use a list not a vector
- powerpc has weird callstack residue
- make-vector and make-string should not need a reverse step
- faster completion
- console with presentations
- ui browser
- method doc strings
+ ui:
- word preview for parsing words
- mouse enter onto overlapping with interior, but not child, gadget
- menu dragging
- fix up the min thumb size hack
@ -25,6 +24,10 @@
+ compiler/ffi:
- ffi global variables, and get rid of factor_str_error hack
- box/unbox_signed/unsigned_8
- unsigned versions of all alien accessors and setters
- [ [ dup call ] dup call ] infer hangs
- ffi unicode strings: null char security hole
- utf16 string boxing
@ -48,6 +51,7 @@
+ kernel:
- clean up metaclasses
- unify unparse and prettyprint
- condition system with restarts
- nicer way to combine two paths

8
factor/DefaultVocabularyLookup.java
View File

@ -136,6 +136,14 @@ public class DefaultVocabularyLookup implements VocabularyLookup
tuple.parsing = new Tuple(tuple);
FactorWord primitive = define("syntax","PRIMITIVE:");
primitive.parsing = new Primitive(primitive);
/* Alien */
FactorWord beginStruct = define("alien","BEGIN-STRUCT:");
beginStruct.parsing = new BeginStruct(beginStruct);
FactorWord endStruct = define("alien","END-STRUCT");
endStruct.parsing = new EndStruct(beginStruct,endStruct);
FactorWord field = define("alien","FIELD:");
field.parsing = new Field(field);
} //}}}
//{{{ getVocabulary() method

1
factor/jedit/FactorPlugin.java
View File

@ -537,6 +537,7 @@ public class FactorPlugin extends EditPlugin
{
offset = buffer.getLineEndOffset(i) - 1;
leadingNewline = true;
break;
}
else if(text.startsWith("!"))
{

4
factor/jedit/FactorWordRenderer.java
View File

@ -45,9 +45,7 @@ public class FactorWordRenderer extends DefaultListCellRenderer
if(showIn)
{
str = jEdit.getProperty("factor.completion.in",
new Object[] {
MiscUtilities.charsToEntities(word.vocabulary)
}) + str;
new Object[] { word.vocabulary }) + str;
}
if(word.stackEffect != null)

53
factor/parser/BeginStruct.java Normal file
View File

@ -0,0 +1,53 @@
/* :folding=explicit:collapseFolds=1: */
/*
* $Id$
*
* Copyright (C) 2005 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.
*/
package factor.parser;
import factor.*;
public class BeginStruct extends FactorParsingDefinition
{
public BeginStruct(FactorWord word)
{
super(word);
}
public void eval(FactorReader reader) throws Exception
{
Object next = reader.nextNonEOL(false,false);
if(!(next instanceof String))
{
reader.getScanner().error("Missing struct name");
return;
}
String structName = (String)next;
reader.intern("<" + structName + ">",true);
reader.pushState(word,null);
}
}

48
factor/parser/EndStruct.java Normal file
View File

@ -0,0 +1,48 @@
/* :folding=explicit:collapseFolds=1: */
/*
* $Id$
*
* Copyright (C) 2005 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.
*/
package factor.parser;
import factor.*;
public class EndStruct extends FactorParsingDefinition
{
private FactorWord start;
public EndStruct(FactorWord start, FactorWord word)
{
super(word);
this.start = start;
}
public void eval(FactorReader reader) throws FactorParseException
{
reader.popState(start,null);
}
}

58
factor/parser/Field.java Normal file
View File

@ -0,0 +1,58 @@
/* :folding=explicit:collapseFolds=1: */
/*
* $Id$
*
* Copyright (C) 2005 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.
*/
package factor.parser;
import factor.*;
import java.io.IOException;
public class Field extends FactorParsingDefinition
{
public Field(FactorWord word)
{
super(word);
}
public void eval(FactorReader reader)
throws IOException, FactorParseException
{
Object type = reader.nextNonEOL(false,false);
if(!(type instanceof String))
{
reader.getScanner().error("Missing field type");
return;
}
Object name = reader.nextNonEOL(false,false);
if(!(name instanceof String))
{
reader.getScanner().error("Missing field name");
return;
}
}
}

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

@ -56,12 +56,14 @@ hashtables ;
"delegate" [ "generic" ] search
"object" [ "generic" ] search
"classes" [ "generic" ] search
"builtins" [ "generic" ] search
vocabularies get [ "generic" off ] bind
reveal
reveal
reveal
reveal
[
"/library/generic/generic.factor"

61
library/bootstrap/image.factor
View File

@ -1,29 +1,5 @@
! :folding=none:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 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.
! See http://factor.sf.net/license.txt for BSD license.
! This library allows one to generate a new set of bootstrap
! images (boot.image.{le32,le64,be32,be64}.
@ -39,24 +15,8 @@
! run platform/native/boot-stage2.factor.
IN: image
USE: errors
USE: generic
USE: kernel-internals
USE: hashtables
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: prettyprint
USE: random
USE: stdio
USE: streams
USE: strings
USE: test
USE: vectors
USE: unparser
USE: words
USE: parser
USING: errors generic hashtables kernel lists math namespaces
parser prettyprint stdio streams strings vectors words ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -285,14 +245,6 @@ M: string ' ( string -- pointer )
M: vector ' ( vector -- pointer )
emit-vector ;
! : rehash ( hashtable -- )
! ! Now make a rehashing boot quotation
! dup hash>alist [
! over hash-clear
! [ unswons rot set-hash ] each-with
! ] cons cons
! boot-quot [ append ] change ;
: emit-hashtable ( hash -- pointer )
dup buckets>list emit-array swap hash>alist length
object-tag here-as >r
@ -324,7 +276,9 @@ M: hashtable ' ( hashtable -- pointer )
vocabularies get
dup vocabularies,
<namespace> [
classes [ ] change vocabularies set
vocabularies set
classes [ ] change
builtins [ ] change
] extend '
global-offset fixup ;
@ -361,9 +315,6 @@ M: hashtable ' ( hashtable -- pointer )
[
300000 <vector> image set
<namespace> "objects" set
! Note that this is a vector that we can side-effect,
! since ; ends up using this variable from nested
! parser namespaces.
call
image get
] with-scope ;

30
library/bootstrap/primitives.factor
View File

@ -18,6 +18,7 @@ classes
<namespace> vocabularies set
<namespace> classes set
num-types <vector> builtins set
<namespace> crossref set
vocabularies get [
@ -170,14 +171,27 @@ vocabularies get [
[ "dlclose" "alien" [ [ dll ] [ ] ] ]
[ "<alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "<local-alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "alien-cell" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-cell" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-4" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-4" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-2" "alien" [ [ alien integer ] [ fixnum ] ] ]
[ "set-alien-2" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-1" "alien" [ [ alien integer ] [ fixnum ] ] ]
[ "set-alien-1" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-signed-cell" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-cell" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-cell" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-unsigned-cell" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-signed-8" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-8" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-8" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-unsigned-8" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-signed-4" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-4" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-4" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-unsigned-4" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-signed-2" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-2" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-2" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-unsigned-2" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-signed-1" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-1" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-1" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-unsigned-1" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-value-string" "alien" [ [ alien integer ] [ string ] ] ]
[ "throw" "errors" [ [ object ] [ ] ] ]
[ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ]
[ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ]

113
library/compiler/alien-types.factor
View File

@ -34,21 +34,18 @@ namespaces parser strings words ;
0 "width" set
] extend ;
: c-types ( -- ns )
global [ "c-types" get ] bind ;
SYMBOL: c-types
: c-type ( name -- type )
global [
dup "c-types" get hash [ ] [
dup c-types get hash [ ] [
"No such C type: " swap cat2 throw f
] ?ifte
] bind ;
] ?ifte ;
: size ( name -- size )
c-type [ "width" get ] bind ;
: define-c-type ( quot name -- )
c-types [ >r <c-type> swap extend r> set ] bind ; inline
c-types get [ >r <c-type> swap extend r> set ] bind ; inline
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
@ -63,7 +60,7 @@ namespaces parser strings words ;
[ "setter" get ] bind cons r> swap define-compound ;
: define-field ( offset type name -- offset )
>r c-type dup >r [ "width" get ] bind align r> r>
>r c-type dup >r [ "align" get ] bind align r> r>
"struct-name" get swap "-" swap cat3
( offset type name -- )
3dup define-getter 3dup define-setter
@ -85,7 +82,8 @@ namespaces parser strings words ;
#! Define inline and pointer type for the struct. Pointer
#! type is exactly like void*.
[ "width" set ] "struct-name" get define-c-type
"void*" c-type "struct-name" get "*" cat2 c-types set-hash ;
"void*" c-type "struct-name" get "*" cat2
c-types get set-hash ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
@ -109,93 +107,126 @@ namespaces parser strings words ;
#! C null value.
0 <alien> ;
global [ <namespace> "c-types" set ] bind
global [ <namespace> c-types set ] bind
[
[ alien-cell <alien> ] "getter" set
[ set-alien-cell ] "setter" set
[ alien-unsigned-cell <alien> ] "getter" set
[ alien-address set-alien-unsigned-cell ] "setter" set
cell "width" set
cell "align" set
"box_alien" "boxer" set
"unbox_alien" "unboxer" set
] "void*" define-c-type
! FIXME
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
4 "width" set
"box_integer" "boxer" set
"unbox_integer" "unboxer" set
] "long" define-c-type
[ alien-signed-8 ] "getter" set
[ set-alien-signed-8 ] "setter" set
8 "width" set
8 "align" set
"box_signed_8" "boxer" set
"unbox_signed_8" "unboxer" set
] "longlong" define-c-type
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
[ alien-unsigned-8 ] "getter" set
[ set-alien-unsigned-8 ] "setter" set
8 "width" set
8 "align" set
"box_unsinged_8" "boxer" set
"unbox_unsigned_8" "unboxer" set
] "ulonglong" define-c-type
[
[ alien-signed-4 ] "getter" set
[ set-alien-signed-4 ] "setter" set
4 "width" set
"box_integer" "boxer" set
"unbox_integer" "unboxer" set
4 "align" set
"box_signed_4" "boxer" set
"unbox_signed_4" "unboxer" set
] "int" define-c-type
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
[ alien-unsigned-4 ] "getter" set
[ set-alien-unsigned-4 ] "setter" set
4 "width" set
"box_cell" "boxer" set
"unbox_cell" "unboxer" set
4 "align" set
"box_unsigned_4" "boxer" set
"unbox_unsigned_4" "unboxer" set
] "uint" define-c-type
[
[ alien-2 ] "getter" set
[ set-alien-2 ] "setter" set
[ alien-signed-2 ] "getter" set
[ set-alien-signed-2 ] "setter" set
2 "width" set
2 "align" set
"box_signed_2" "boxer" set
"unbox_signed_2" "unboxer" set
] "short" define-c-type
[
[ alien-2 ] "getter" set
[ set-alien-2 ] "setter" set
[ alien-unsigned-2 ] "getter" set
[ set-alien-unsigned-2 ] "setter" set
2 "width" set
2 "align" set
"box_unsigned_2" "boxer" set
"unbox_unsigned_2" "unboxer" set
] "ushort" define-c-type
[
[ alien-1 ] "getter" set
[ set-alien-1 ] "setter" set
[ alien-signed-1 ] "getter" set
[ set-alien-signed-1 ] "setter" set
1 "width" set
1 "align" set
"box_signed_1" "boxer" set
"unbox_signed_1" "unboxer" set
] "char" define-c-type
[
[ alien-1 ] "getter" set
[ set-alien-1 ] "setter" set
[ alien-unsigned-1 ] "getter" set
[ set-alien-unsigned-1 ] "setter" set
1 "width" set
1 "align" set
"box_unsigned_1" "boxer" set
"unbox_unsigned_1" "unboxer" set
] "uchar" define-c-type
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
[ alien-unsigned-4 ] "getter" set
[ set-alien-unsigned-4 ] "setter" set
cell "width" set
cell "align" set
"box_c_string" "boxer" set
"unbox_c_string" "unboxer" set
] "char*" define-c-type
! This is not the best way to do it.
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
[ alien-value-string ] "getter" set
256 "width" set
cell "align" set
] "uchar256" define-c-type
[
[ alien-unsigned-4 ] "getter" set
[ set-alien-unsigned-4 ] "setter" set
cell "width" set
cell "align" set
"box_utf16_string" "boxer" set
"unbox_utf16_string" "unboxer" set
] "ushort*" define-c-type
[
[ alien-4 0 = not ] "getter" set
[ 1 0 ? set-alien-4 ] "setter" set
[ alien-unsigned-4 0 = not ] "getter" set
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
cell "width" set
cell "align" set
"box_boolean" "boxer" set
"unbox_boolean" "unboxer" set
] "bool" define-c-type
: alias-c-type ( old new -- )
c-types get [ >r get r> set ] bind ;
! FIXME for 64-bit platforms
"int" "long" alias-c-type
"uint" "ulong" alias-c-type

3
library/compiler/alien.factor
View File

@ -26,6 +26,9 @@ unparser words ;
: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
: null>f ( alien -- alien/f )
dup alien-address 0 = [ drop f ] when ;
M: alien hashcode ( obj -- n )
alien-address >fixnum ;

12
library/compiler/assembler.factor
View File

@ -8,10 +8,14 @@ SYMBOL: interned-literals
: cell 4 ; inline
: compiled-header HEX: 01c3babe ; inline
: compiled-byte ( a -- n ) <alien> 0 alien-1 ; inline
: set-compiled-byte ( n a -- ) <alien> 0 set-alien-1 ; inline
: compiled-cell ( a -- n ) <alien> 0 alien-cell ; inline
: set-compiled-cell ( n a -- ) <alien> 0 set-alien-cell ; inline
: compiled-byte ( a -- n )
<alien> 0 alien-signed-1 ; inline
: set-compiled-byte ( n a -- )
<alien> 0 set-alien-signed-1 ; inline
: compiled-cell ( a -- n )
<alien> 0 alien-signed-cell ; inline
: set-compiled-cell ( n a -- )
<alien> 0 set-alien-signed-cell ; inline
: compile-aligned ( n -- )
compiled-offset cell 2 * align set-compiled-offset ; inline

7
library/generic/builtin.factor
View File

@ -7,6 +7,9 @@ words vectors ;
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins
builtin [
"builtin-type" word-prop unit
] "builtin-supertypes" set-word-prop
@ -38,13 +41,13 @@ builtin [ 2drop t ] "class<" set-word-prop
] ifte ;
: builtin-class ( symbol type# slotspec -- )
>r 2dup builtins get set-vector-nth r>
>r swap
dup intern-symbol
2dup builtin-predicate
[ swap "builtin-type" set-word-prop ] keep
dup builtin define-class r> define-slots ;
: builtin-type ( n -- symbol )
unit classes get hash ;
: builtin-type ( n -- symbol ) builtins get vector-nth ;
PREDICATE: word builtin metaclass builtin = ;

8
library/generic/tuple.factor
View File

@ -18,7 +18,7 @@ hashtables errors vectors ;
#! specifying an incorrect size.
<tuple> [ 0 swap set-array-nth ] keep ;
: tuple-class 2 slot ; inline
: class-tuple 2 slot ; inline
IN: generic
@ -42,7 +42,7 @@ UNION: arrayed array tuple ;
: class ( obj -- class )
#! The class of an object.
dup tuple? [ tuple-class ] [ type builtin-type ] ifte ;
dup tuple? [ class-tuple ] [ type builtin-type ] ifte ;
: (literal-tuple) ( list size -- tuple )
dup <tuple> swap [
@ -154,7 +154,7 @@ UNION: arrayed array tuple ;
#! for methods defined on the given generic.
dup default-tuple-method \ drop swons
swap "methods" word-prop hash>quot
[ dup tuple-class ] swap append ;
[ dup class-tuple ] swap append ;
: add-tuple-dispatch ( word vtable -- )
>r tuple-dispatch-quot tuple r> set-vtable ;
@ -173,7 +173,7 @@ M: tuple clone ( tuple -- tuple )
M: tuple = ( obj tuple -- ? )
over tuple? [
over class over class = [
over class-tuple over class-tuple eq? [
swap tuple>list swap tuple>list =
] [
2drop f

13
library/inference/words.factor
View File

@ -107,14 +107,14 @@ M: compound apply-word ( word -- )
"Dynamic dispatch for " swap word-name cat2
inference-warning ;
M: generic apply-word ( word -- )
#! If the type of the value at the top of the stack is
#! known, inline the method body.
[ object ] ensure-d
! M: generic apply-word ( word -- )
! #! If the type of the value at the top of the stack is
! #! known, inline the method body.
! [ object ] ensure-d
! literal-type? branches-can-fail? not and [
! inline-compound 2drop
! ] [
dup dynamic-dispatch-warning apply-default ;
! dup dynamic-dispatch-warning apply-default ;
! ] ifte ;
: with-recursion ( quot -- )
@ -171,7 +171,8 @@ M: word apply-object ( word -- )
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ object ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop

2
library/test/alien.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: alien
USE: kernel
USE: test

7
library/test/annotate.factor Normal file
View File

@ -0,0 +1,7 @@
IN: temporary
USING: words ;
: foo ;
\ foo watch
[ ] [ foo ] unit-test

2
library/test/benchmark/continuations.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/benchmark/empty-loop.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: kernel
USE: math

2
library/test/benchmark/fac.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: math
USE: test
USE: compiler

2
library/test/benchmark/fib.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: kernel
USE: math

2
library/test/benchmark/sort.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: kernel
USE: math

2
library/test/buffer.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad USING: test kernel kernel-internals ;
IN: temporary USING: test kernel kernel-internals ;
: with-buffer ( size quot -- )
>r <buffer> r> keep buffer-free ;

2
library/test/combinators.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/compiler/bail-out.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: errors
USE: math

2
library/test/compiler/generic.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: generic
USE: test

2
library/test/compiler/ifte.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: test
USE: math

2
library/test/compiler/linearizer.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: test
USE: kernel
USE: compiler

2
library/test/compiler/optimizer.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: test
USE: compiler
USE: inference

2
library/test/compiler/simple.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: test
USE: math

2
library/test/compiler/simplifier.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: test
USE: inference

2
library/test/compiler/stack.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: compiler
USE: test
USE: words

2
library/test/continuations.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: lists
USE: math

2
library/test/crashes.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
! Various things that broke CFactor at various times.
USING: errors kernel lists math memory namespaces parser

2
library/test/dataflow.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: inference
USE: lists
USE: math

2
library/test/errors.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: errors
USE: kernel
USE: namespaces

2
library/test/files.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: files
USE: httpd
USE: lists

2
library/test/gadgets.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: gadgets kernel lists math namespaces test ;
[ t ] [

6
library/test/generic.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: parser prettyprint stdio ;
USE: hashtables
@ -122,12 +122,12 @@ TUPLE: another-one ;
[ << another-one f >> ] [ <another-one> empty-method-test ] unit-test
! Test generic see and parsing
[ "IN: scratchpad\nSYMBOL: bah \nUNION: bah fixnum alien ;\n" ]
[ "IN: temporary\nSYMBOL: bah \nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string ] unit-test
[ t ] [
DEFER: not-fixnum
"IN: scratchpad\nSYMBOL: not-fixnum \nCOMPLEMENT: not-fixnum fixnum\n"
"IN: temporary\nSYMBOL: not-fixnum \nCOMPLEMENT: not-fixnum fixnum\n"
dup eval
[ \ not-fixnum see ] with-string =
] unit-test

2
library/test/hashtables.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: hashtables
USE: kernel
USE: lists

2
library/test/httpd/html.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: html
USE: namespaces
USE: stdio

2
library/test/httpd/httpd.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: file-responder
USE: httpd
USE: httpd-responder

2
library/test/httpd/url-encoding.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: url-encoding
USE: test

2
library/test/inference.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: test
USE: inference
USE: math

2
library/test/init.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: command-line
USE: namespaces
USE: test

2
library/test/interpreter.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: vectors
USE: interpreter
USE: test

2
library/test/io/io.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: namespaces
USE: parser
USE: streams

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

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: namespaces
USE: line-editor
USE: test

2
library/test/listener.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: namespaces
USE: stdio
USE: test

2
library/test/lists/assoc.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: math
USE: namespaces

2
library/test/lists/combinators.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: lists
USE: math

2
library/test/lists/cons.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: test

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

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: lists
USE: math

2
library/test/lists/namespaces.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: namespaces
USE: test

2
library/test/lists/queues.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: kernel lists test ;
[ [ 1 2 3 4 5 ] ] [

2
library/test/math/bignum.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: math
USE: test
USE: unparser

2
library/test/math/bitops.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/math/complex.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/math/float.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/math/gcd.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: math
USE: test

2
library/test/math/irrational.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: math-internals

2
library/test/math/math-combinators.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/math/rational.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: math
USE: test

2
library/test/memory.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: generic kernel lists math memory words ;
num-types [

2
library/test/namespaces.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: namespaces
USE: test

2
library/test/parse-number.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: math
USE: parser
USE: strings

4
library/test/parser.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: parser
USE: test
USE: unparser
@ -37,7 +37,7 @@ unit-test
[ "hello world" ]
[
"IN: scratchpad : hello \"hello world\" ;"
"IN: temporary : hello \"hello world\" ;"
parse call "USE: scratchpad hello" eval
] unit-test

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

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: parser
USE: test

2
library/test/prettyprint.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: prettyprint
USE: test

2
library/test/random.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: kernel
USE: lists
USE: math

2
library/test/redefine.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: compiler inference math ;
USE: test

2
library/test/sbuf.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: errors
USE: kernel
USE: math

2
library/test/stream.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: namespaces
USE: streams
USE: stdio

2
library/test/strings.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: errors
USE: kernel
USE: math

3
library/test/test.factor
View File

@ -43,7 +43,7 @@ prettyprint stdio strings words vectors unparser ;
: all-tests ( -- )
"Running Factor test suite..." print
vocabularies get [ "scratchpad" off ] bind
vocabularies get [ "temporary" off ] bind
[
"lists/cons"
"lists/lists"
@ -94,6 +94,7 @@ prettyprint stdio strings words vectors unparser ;
"gadgets"
"memory"
"redefine"
"annotate"
] [
test
] each

2
library/test/threads.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: namespaces
USE: stdio

2
library/test/tuple.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: generic kernel test math parser ;
TUPLE: rect x y w h ;

2
library/test/unparser.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USE: lists
USE: math
USE: parser

2
library/test/words.factor
View File

@ -1,4 +1,4 @@
IN: scratchpad
IN: temporary
USING: generic kernel lists math namespaces test words ;
[ 4 ] [

12
library/tools/annotations.factor
View File

@ -6,10 +6,10 @@ IN: words
! or single-stepping. Note that currently, words referring to
! annotated words cannot be compiled; and annotating a word has
! no effect of compiled calls to that word.
USING: interpreter kernel lists stdio strings ;
USING: interpreter kernel lists stdio strings test ;
: annotate ( word quot -- ) #! Quotation: ( word def -- def )
over [ word-def swap call ] keep (define-compound) ;
>r dup dup word-def r> call (define-compound) ; inline
: (watch) >r "==> " swap word-name cat2 \ print r> cons cons ;
@ -19,8 +19,10 @@ USING: interpreter kernel lists stdio strings ;
#! word with \ foo reload.
[ (watch) ] annotate ;
: (break) [ walk ] cons ;
: break ( word -- )
#! Cause the word to start the code walker when executed.
[ nip (break) ] annotate ;
[ nip [ walk ] cons ] annotate ;
: timer ( word -- )
#! Print the time taken to execute the word when it's called.
[ nip [ time ] cons ] annotate ;

84
native/bignum.c
View File

@ -1,23 +1,5 @@
#include "factor.h"
/* FFI calls this */
void box_integer(F_FIXNUM integer)
{
dpush(tag_integer(integer));
}
/* FFI calls this */
void box_cell(CELL cell)
{
dpush(tag_cell(cell));
}
/* FFI calls this */
F_FIXNUM unbox_integer(void)
{
return to_fixnum(dpop());
}
CELL to_cell(CELL x)
{
F_FIXNUM fixnum;
@ -50,12 +32,6 @@ CELL to_cell(CELL x)
}
}
/* FFI calls this */
CELL unbox_cell(void)
{
return to_cell(dpop());
}
F_ARRAY* to_bignum(CELL tagged)
{
F_RATIO* r;
@ -238,3 +214,63 @@ void copy_bignum_constants(void)
COPY_OBJECT(bignum_pos_one);
COPY_OBJECT(bignum_neg_one);
}
void box_signed_cell(F_FIXNUM integer)
{
dpush(tag_integer(integer));
}
F_FIXNUM unbox_signed_cell(void)
{
return to_fixnum(dpop());
}
void box_unsigned_cell(CELL cell)
{
dpush(tag_cell(cell));
}
F_FIXNUM unbox_unsigned_cell(void)
{
return to_cell(dpop());
}
void box_signed_4(s32 n)
{
dpush(tag_bignum(s48_long_to_bignum(n)));
}
s32 unbox_signed_4(void)
{
return s48_bignum_to_long(to_bignum(dpop()));
}
void box_unsigned_4(u32 n)
{
dpush(tag_bignum(s48_ulong_to_bignum(n)));
}
u32 unbox_unsigned_4(void)
{
return s48_bignum_to_ulong(to_bignum(dpop()));
}
void box_signed_8(s64 n)
{
dpush(tag_bignum(s48_long_long_to_bignum(n)));
}
s64 unbox_signed_8(void)
{
return 0; /* s48_bignum_to_long_long(to_bignum(dpop())); */
}
void box_unsigned_8(u64 n)
{
dpush(tag_bignum(s48_long_long_to_bignum(n)));
}
u64 unbox_unsigned_8(void)
{
return 0; /* s48_bignum_to_long_long(to_bignum(dpop())); */
}

24
native/bignum.h
View File

@ -20,11 +20,7 @@ INLINE CELL tag_bignum(F_ARRAY* bignum)
CELL to_cell(CELL x);
DLLEXPORT void box_integer(F_FIXNUM integer);
DLLEXPORT void box_cell(CELL cell);
DLLEXPORT F_FIXNUM unbox_integer(void);
CELL to_cell(CELL x);
DLLEXPORT CELL unbox_cell(void);
F_ARRAY* to_bignum(CELL tagged);
void primitive_to_bignum(void);
void primitive_bignum_eq(void);
@ -45,7 +41,6 @@ void primitive_bignum_greater(void);
void primitive_bignum_greatereq(void);
void primitive_bignum_not(void);
void copy_bignum_constants(void);
CELL three_test(void* x, unsigned char r, unsigned char g, unsigned char b);
INLINE CELL tag_integer(F_FIXNUM x)
{
@ -62,3 +57,22 @@ INLINE CELL tag_cell(CELL x)
else
return tag_fixnum(x);
}
/* FFI calls this */
void box_signed_cell(F_FIXNUM integer);
DLLEXPORT F_FIXNUM unbox_signed_cell(void);
DLLEXPORT void box_unsigned_cell(CELL cell);
DLLEXPORT F_FIXNUM unbox_unsigned_cell(void);
DLLEXPORT void box_signed_4(s32 n);
DLLEXPORT s32 unbox_signed_4(void);
DLLEXPORT void box_unsigned_4(u32 n);
DLLEXPORT u32 unbox_unsigned_4(void);
DLLEXPORT void box_signed_8(s64 n);
DLLEXPORT s64 unbox_signed_8(void);
DLLEXPORT void box_unsigned_8(u64 n);
DLLEXPORT u64 unbox_unsigned_8(void);

8
native/compiler.c
View File

@ -8,23 +8,23 @@ void init_compiler(CELL size)
void primitive_compiled_offset(void)
{
box_integer(compiling.here);
box_unsigned_cell(compiling.here);
}
void primitive_set_compiled_offset(void)
{
CELL offset = unbox_integer();
CELL offset = unbox_unsigned_cell();
compiling.here = offset;
}
void primitive_literal_top(void)
{
box_integer(literal_top);
box_unsigned_cell(literal_top);
}
void primitive_set_literal_top(void)
{
CELL offset = unbox_integer();
CELL offset = unbox_unsigned_cell();
if(offset >= literal_max)
critical_error("Too many compiled literals",offset);
literal_top = offset;

86
native/ffi.c
View File

@ -60,7 +60,7 @@ void box_alien(void* ptr)
INLINE void* alien_pointer(void)
{
F_FIXNUM offset = unbox_integer();
F_FIXNUM offset = unbox_signed_cell();
ALIEN* alien = untag_alien(dpop());
void* ptr = alien->ptr;
@ -72,14 +72,14 @@ INLINE void* alien_pointer(void)
void primitive_alien(void)
{
void* ptr = (void*)unbox_integer();
void* ptr = (void*)unbox_signed_cell();
maybe_garbage_collection();
box_alien(ptr);
}
void primitive_local_alien(void)
{
F_FIXNUM length = unbox_integer();
F_FIXNUM length = unbox_signed_cell();
ALIEN* alien;
F_STRING* local;
if(length < 0)
@ -99,57 +99,7 @@ void primitive_local_alienp(void)
void primitive_alien_address(void)
{
box_cell((CELL)untag_alien(dpop())->ptr);
}
void primitive_alien_cell(void)
{
box_integer(*(int*)alien_pointer());
}
void primitive_set_alien_cell(void)
{
CELL* ptr = alien_pointer();
CELL value = unbox_integer();
*ptr = value;
}
void primitive_alien_4(void)
{
int* ptr = alien_pointer();
box_integer(*ptr);
}
void primitive_set_alien_4(void)
{
int* ptr = alien_pointer();
int value = unbox_integer();
*ptr = value;
}
void primitive_alien_2(void)
{
u16* ptr = alien_pointer();
box_signed_2(*ptr);
}
void primitive_set_alien_2(void)
{
u16* ptr = alien_pointer();
CELL value = unbox_signed_2();
*ptr = value;
}
void primitive_alien_1(void)
{
box_signed_1(*(BYTE*)alien_pointer());
}
void primitive_set_alien_1(void)
{
BYTE* ptr = alien_pointer();
BYTE value = value = unbox_signed_1();
*ptr = value;
box_unsigned_cell((CELL)untag_alien(dpop())->ptr);
}
void fixup_dll(DLL* dll)
@ -177,3 +127,31 @@ void collect_alien(ALIEN* alien)
alien->ptr = (void*)(ptr + 1);
}
}
#define DEF_ALIEN_SLOT(name,type,boxer) \
void primitive_alien_##name (void) \
{ \
box_##boxer (*(type*)alien_pointer()); \
} \
void primitive_set_alien_##name (void) \
{ \
type* ptr = alien_pointer(); \
type value = unbox_##boxer (); \
*ptr = value; \
}
DEF_ALIEN_SLOT(signed_cell,int,signed_cell)
DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell)
DEF_ALIEN_SLOT(signed_8,s64,signed_8)
DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8)
DEF_ALIEN_SLOT(signed_4,s32,signed_4)
DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4)
DEF_ALIEN_SLOT(signed_2,s16,signed_2)
DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2)
DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
void primitive_alien_value_string(void)
{
box_c_string(alien_pointer());
}

37
native/ffi.h
View File

@ -30,19 +30,32 @@ void primitive_dlsym(void);
void primitive_dlclose(void);
void primitive_alien(void);
void primitive_local_alien(void);
DLLEXPORT void* unbox_alien(void);
DLLEXPORT void box_alien(void* ptr);
void primitive_local_alienp(void);
void primitive_alien_address(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);
void fixup_dll(DLL* dll);
void collect_dll(DLL* dll);
void fixup_alien(ALIEN* alien);
void collect_alien(ALIEN* alien);
DLLEXPORT void* unbox_alien(void);
DLLEXPORT void box_alien(void* ptr);
void primitive_local_alienp(void);
void primitive_alien_address(void);
void primitive_alien_signed_cell(void);
void primitive_set_alien_signed_cell(void);
void primitive_alien_unsigned_cell(void);
void primitive_set_alien_unsigned_cell(void);
void primitive_alien_signed_8(void);
void primitive_set_alien_signed_8(void);
void primitive_alien_unsigned_8(void);
void primitive_set_alien_unsigned_8(void);
void primitive_alien_signed_4(void);
void primitive_set_alien_signed_4(void);
void primitive_alien_unsigned_4(void);
void primitive_set_alien_unsigned_4(void);
void primitive_alien_signed_2(void);
void primitive_set_alien_signed_2(void);
void primitive_alien_unsigned_2(void);
void primitive_set_alien_unsigned_2(void);
void primitive_alien_signed_1(void);
void primitive_set_alien_signed_1(void);
void primitive_alien_unsigned_1(void);
void primitive_set_alien_unsigned_1(void);
void primitive_alien_value_string(void);

13
native/fixnum.c
View File

@ -36,14 +36,14 @@ void primitive_fixnum_add(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
box_integer(x + y);
box_signed_cell(x + y);
}
void primitive_fixnum_subtract(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
box_integer(x - y);
box_signed_cell(x - y);
}
/**
@ -62,7 +62,7 @@ void primitive_fixnum_multiply(void)
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
box_integer(prod);
box_signed_cell(prod);
else
{
dpush(tag_bignum(
@ -77,7 +77,7 @@ void primitive_fixnum_divint(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
box_integer(x / y);
box_signed_cell(x / y);
}
void primitive_fixnum_divfloat(void)
@ -91,8 +91,8 @@ void primitive_fixnum_divmod(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
box_integer(x / y);
box_integer(x % y);
box_signed_cell(x / y);
box_signed_cell(x % y);
}
void primitive_fixnum_mod(void)
@ -216,4 +216,3 @@ DEFUNBOX(unbox_signed_1, signed char)
DEFUNBOX(unbox_signed_2, signed short)
DEFUNBOX(unbox_unsigned_1, unsigned char)
DEFUNBOX(unbox_unsigned_2, unsigned short)

1
native/io.h
View File

@ -63,5 +63,6 @@ bool set_up_fd_set(fd_set* fdset, int fd_count, IO_TASK* io_tasks,
CELL perform_io_task(IO_TASK* io_task, IO_TASK* io_tasks, int* fd_count);
CELL perform_io_tasks(fd_set* fdset, IO_TASK* io_tasks, int* fd_count);
CELL next_io_task(void);
char* factor_str_error(void);
#endif

8
native/memory.c
View File

@ -97,10 +97,10 @@ bool in_zone(ZONE* z, CELL pointer)
void primitive_room(void)
{
box_integer(compiling.limit - compiling.here);
box_integer(compiling.limit - compiling.base);
box_integer(active.limit - active.here);
box_integer(active.limit - active.base);
box_signed_cell(compiling.limit - compiling.here);
box_signed_cell(compiling.limit - compiling.base);
box_signed_cell(active.limit - active.here);
box_signed_cell(active.limit - active.base);
}
void primitive_allot_profiling(void)

29
native/primitives.c
View File

@ -146,14 +146,27 @@ void* primitives[] = {
primitive_dlclose,
primitive_alien,
primitive_local_alien,
primitive_alien_cell,
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,
primitive_alien_signed_cell,
primitive_set_alien_signed_cell,
primitive_alien_unsigned_cell,
primitive_set_alien_unsigned_cell,
primitive_alien_signed_8,
primitive_set_alien_signed_8,
primitive_alien_unsigned_8,
primitive_set_alien_unsigned_8,
primitive_alien_signed_4,
primitive_set_alien_signed_4,
primitive_alien_unsigned_4,
primitive_set_alien_unsigned_4,
primitive_alien_signed_2,
primitive_set_alien_signed_2,
primitive_alien_unsigned_2,
primitive_set_alien_unsigned_2,
primitive_alien_signed_1,
primitive_set_alien_signed_1,
primitive_alien_unsigned_1,
primitive_set_alien_unsigned_1,
primitive_alien_value_string,
primitive_throw,
primitive_string_to_memory,
primitive_memory_to_string,

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern void* primitives[];
#define PRIMITIVE_COUNT 194
#define PRIMITIVE_COUNT 186
CELL primitive_to_xt(CELL primitive);

6
native/string.c
View File

@ -74,8 +74,8 @@ INLINE F_STRING* memory_to_string(const BYTE* string, CELL length)
void primitive_memory_to_string(void)
{
CELL length = unbox_cell();
BYTE* string = (BYTE*)unbox_cell();
CELL length = unbox_unsigned_cell();
BYTE* string = (BYTE*)unbox_unsigned_cell();
dpush(tag_object(memory_to_string(string,length)));
}
@ -116,7 +116,7 @@ INLINE void string_to_memory(F_STRING* s, BYTE* string)
void primitive_string_to_memory(void)
{
BYTE* address = (BYTE*)unbox_cell();
BYTE* address = (BYTE*)unbox_unsigned_cell();
F_STRING* str = untag_string(dpop());
string_to_memory(str,address);
}

6
native/unix/io.c
View File

@ -303,3 +303,9 @@ void collect_io_tasks(void)
COPY_OBJECT(write_io_tasks[i].callbacks);
}
}
/* FFI calls this */
char* factor_str_error(void)
{
return strerror(errno);
}