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

added new tuple metaclass, eventually to replace the traits metaclass

cvs
Slava Pestov 2005-01-29 21:39:30 +00:00
parent 5b524a0fff
commit 93dc7ce736
23 changed files with 163 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -39,6 +39,7 @@
- maple-like: press enter at old commands to evaluate there
- completion in the listener
- special completion for USE:/IN:
- support USING:
+ i/o:

4
factor/parser/Using.java
View File

@ -3,7 +3,7 @@
/*
* $Id$
*
* Copyright (C) 2004 Slava Pestov.
* 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:
@ -44,7 +44,7 @@ public class Using extends FactorParsingDefinition
for(;;)
{
Object next = reader.next(false,false);
if(next == null)
if(next == FactorScanner.EOF)
reader.getScanner().error("Expected ;");
if(next.equals(";"))
break;

36
library/bootstrap/boot-stage2.factor
View File

@ -1,37 +1,6 @@
! :folding=indent: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.
IN: init
USE: kernel
USE: lists
USE: parser
USE: stdio
USE: words
USE: namespaces
! See http://factor.sf.net/license.txt for BSD license.
USING: kernel lists parser stdio words namespaces ;
"Cold boot in progress..." print
@ -44,6 +13,7 @@ USE: namespaces
"/library/generic/union.factor"
"/library/generic/complement.factor"
"/library/generic/traits.factor"
"/library/generic/tuple.factor"
"/version.factor"
"/library/stack.factor"

39
library/bootstrap/boot.factor
View File

@ -1,39 +1,7 @@
! :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.
USE: lists
USE: image
USE: parser
USE: namespaces
USE: stdio
USE: kernel
USE: vectors
USE: words
USE: hashtables
! See http://factor.sf.net/license.txt for BSD license.
USING: lists image parser namespaces stdio kernel vectors
words hashtables ;
"/library/bootstrap/primitives.factor" run-resource
@ -88,6 +56,7 @@ USE: hashtables
"/library/generic/union.factor" parse-resource append,
"/library/generic/complement.factor" parse-resource append,
"/library/generic/traits.factor" parse-resource append,
"/library/generic/tuple.factor" parse-resource append,
"/library/bootstrap/init.factor" parse-resource append,
"/library/syntax/parse-syntax.factor" parse-resource append,

41
library/bootstrap/primitives.factor
View File

@ -1,40 +1,8 @@
! :folding=none: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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: words
USE: vectors
USE: hashtables
USE: generic
USING: kernel lists math namespaces parser words vectors
hashtables generic ;
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab
@ -226,6 +194,7 @@ vocabularies get [
[[ "kernel-internals" "grow-array" ]]
[[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]]
[[ "kernel-internals" "<tuple>" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop

2
library/generic/builtin.factor
View File

@ -83,7 +83,7 @@ builtin [ 2drop t ] "class<" set-word-property
: builtin-type ( n -- symbol )
unit classes get hash ;
: class ( obj -- class )
M: object class ( obj -- class )
#! Analogous to the type primitive. Pushes the builtin
#! class of an object.
type builtin-type ;

78
library/generic/generic.factor
View File

@ -1,50 +1,11 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USE: errors
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
USE: math
USE: math-internals
USE: unparser
USING: errors hashtables kernel kernel-internals lists
namespaces parser strings words vectors math math-internals ;
! A simple single-dispatch generic word system.
! "if I say I'd rather eat cheese than shit... doesn't mean
! those are the only two things I can eat." - Tac
: predicate-word ( word -- word )
word-name "?" cat2 "in" get create ;
@ -60,7 +21,7 @@ USE: unparser
! The class of an object with traits is determined by the object
! identity of the traits method map.
! - metaclass: a metaclass is a symbol with a handful of word
! properties: "define-method" "builtin-types" "priority"
! properties: "builtin-types" "priority"
! Metaclasses have priority -- this induces an order in which
! methods are added to the vtable.
@ -107,12 +68,13 @@ USE: unparser
>r 2dup r> unswons add-method
] each nip ;
: define-generic ( word vtable -- )
: make-generic ( word vtable -- )
over "combination" word-property cons define-compound ;
: (define-method) ( definition class generic -- )
: define-method ( class generic definition -- )
-rot
[ "methods" word-property set-hash ] keep dup <vtable>
define-generic ;
make-generic ;
: init-methods ( word -- )
dup "methods" word-property [
@ -122,15 +84,14 @@ USE: unparser
] ifte ;
! Defining generic words
: (GENERIC) ( combination definer -- )
: define-generic ( combination definer word -- )
#! Takes a combination parameter. A combination is a
#! quotation that takes some objects and a vtable from the
#! stack, and calls the appropriate row of the vtable.
CREATE
[ swap "definer" set-word-property ] keep
[ swap "combination" set-word-property ] keep
dup init-methods
dup <vtable> define-generic ;
dup <vtable> make-generic ;
: single-combination ( obj vtable -- )
>r dup type r> dispatch ; inline
@ -138,7 +99,8 @@ USE: unparser
: GENERIC:
#! GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:.
[ single-combination ] \ GENERIC: (GENERIC) ; parsing
[ single-combination ]
\ GENERIC: CREATE define-generic ; parsing
: arithmetic-combination ( n n vtable -- )
#! Note that the numbers remain on the stack, possibly after
@ -150,19 +112,13 @@ USE: unparser
#! the generic word using M:. 2GENERIC words dispatch on
#! arithmetic types and should not be used for non-numerical
#! types.
[ arithmetic-combination ] \ 2GENERIC: (GENERIC) ; parsing
: define-method ( class -- quotation )
#! In a vain attempt at something resembling a "meta object
#! protocol", we call the "define-method" word property with
#! stack ( class generic definition -- ).
metaclass "define-method" word-property
[ [ -rot (define-method) ] ] unless* ;
[ arithmetic-combination ]
\ 2GENERIC: CREATE define-generic ; parsing
: M: ( -- class generic [ ] )
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
scan-word dup define-method scan-word swap [ ] ; parsing
scan-word scan-word [ define-method ] [ ] ; parsing
! Maps lists of builtin type numbers to class objects.
SYMBOL: classes
@ -210,3 +166,5 @@ SYMBOL: object
classes get set-hash ;
classes get [ <namespace> classes set ] unless
GENERIC: class ( obj -- class )

2
library/generic/traits.factor
View File

@ -67,7 +67,7 @@ SYMBOL: delegate
] "add-method" set-word-property
\ traits [
drop vector "builtin-type" word-property unit
drop hashtable "builtin-type" word-property unit
] "builtin-supertypes" set-word-property
\ traits 10 "priority" set-word-property

91
library/generic/tuple.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: words parser kernel namespaces lists strings
kernel-internals math hashtables errors ;
: make-tuple ( class -- )
dup "tuple-size" word-property <tuple>
[ 0 swap set-array-nth ] keep ;
: define-tuple-generic ( tuple word def -- )
over >r \ single-combination \ GENERIC: r> define-generic
define-method ;
: define-accessor ( word name n -- )
>r [ >r dup word-name , "-" , r> , ] make-string
"in" get create r> [ slot ] cons define-tuple-generic ;
: define-mutator ( word name n -- )
>r [ "set-" , >r dup word-name , "-" , r> , ] make-string
"in" get create r> [ set-slot ] cons define-tuple-generic ;
: define-field ( word name n -- )
3dup define-accessor define-mutator ;
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word swap
[ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons
define-compound ;
: define-tuple ( word fields -- )
2dup length 1 + "tuple-size" set-word-property
dup length [ 3 + ] project zip
[ uncons define-field ] each-with ;
: TUPLE:
#! Followed by a tuple name, then field names, then ;
CREATE
dup intern-symbol
dup tuple-predicate
dup define-promise
dup tuple "metaclass" set-word-property
string-mode on
[ string-mode off define-tuple ]
f ; parsing
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
: tuple-constructor ( word def -- )
over constructor-word >r
[ swap literal, \ make-tuple , append, ] make-list
r> swap define-compound ;
: TC:
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
#! stack.
scan-word [ tuple-constructor ] f ; parsing
: tuple-dispatch ( object selector -- object quot )
over class over "methods" word-property hash* dup [
nip cdr ( method is defined )
] [
! drop delegate rot hash [
! swap tuple-dispatch ( check delegate )
! ] [
[ undefined-method ] ( no delegate )
! ] ifte*
] ifte ;
: add-tuple-dispatch ( word vtable -- )
>r unit [ car tuple-dispatch call ] cons tuple r>
set-vtable ;
M: tuple class ( obj -- class ) 2 slot ;
tuple [
( generic vtable definition class -- )
2drop add-tuple-dispatch
] "add-method" set-word-property
tuple [
drop tuple "builtin-type" word-property unit
] "builtin-supertypes" set-word-property
tuple 10 "priority" set-word-property
tuple [ 2drop t ] "class<" set-word-property

4
library/kernel.factor
View File

@ -7,6 +7,8 @@ IN: kernel-internals USING: generic kernel vectors ;
#! call it directly.
vector-array array-nth call ;
BUILTIN: tuple 18
IN: kernel
GENERIC: hashcode ( obj -- n )
@ -32,7 +34,7 @@ M: object clone ;
: num-types ( -- n )
#! One more than the maximum value from type primitive.
18 ;
19 ;
: ? ( cond t f -- t/f )
#! Push t if cond is true, otherwise push f.

5
library/namespaces.factor
View File

@ -141,3 +141,8 @@ SYMBOL: list-buffer
: append, ( list -- )
[ , ] each ;
: literal, ( word -- )
#! Append some code that pushes the word on the stack. Used
#! when building quotations.
unit , \ car , ;

1
library/primitives.factor
View File

@ -184,6 +184,7 @@ hashtables ;
[ grow-array [ [ integer array ] [ object ] ] ]
[ <hashtable> [ [ number ] [ hashtable ] ] ]
[ <array> [ [ number ] [ array ] ] ]
[ <tuple> [ [ number ] [ tuple ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property

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

@ -20,4 +20,4 @@ USE: test
: vector-benchmark ( n -- )
0 <vector> over fill-vector rot copy-vector ; compiled
[ ] [ 4000000 vector-benchmark ] unit-test
[ ] [ 400000 vector-benchmark ] unit-test

17
native/array.c
View File

@ -10,11 +10,11 @@ F_ARRAY* allot_array(CELL type, CELL capacity)
}
/* untagged */
F_ARRAY* array(CELL capacity, CELL fill)
F_ARRAY* array(CELL type, CELL capacity, CELL fill)
{
int i;
F_ARRAY* array = allot_array(ARRAY_TYPE, capacity);
F_ARRAY* array = allot_array(type, capacity);
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
@ -28,7 +28,16 @@ void primitive_array(void)
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
maybe_garbage_collection();
dpush(tag_object(array(capacity,F)));
dpush(tag_object(array(ARRAY_TYPE,capacity,F)));
}
void primitive_tuple(void)
{
F_FIXNUM capacity = to_fixnum(dpop());
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
maybe_garbage_collection();
dpush(tag_object(array(TUPLE_TYPE,capacity,F)));
}
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
@ -43,7 +52,7 @@ F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,array->capacity * CELLS);
memcpy(new_array + 1,array + 1,curr_cap * CELLS);
for(i = curr_cap; i < capacity; i++)
put(AREF(new_array,i),fill);

3
native/array.h
View File

@ -11,8 +11,9 @@ INLINE F_ARRAY* untag_array(CELL tagged)
}
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL capacity, CELL fill);
F_ARRAY* array(CELL type, CELL capacity, CELL fill);
void primitive_array(void);
void primitive_tuple(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);

4
native/factor.h
View File

@ -101,8 +101,8 @@ DLLEXPORT CELL cs;
typedef unsigned char BYTE;
/* Memory areas */
#define DEFAULT_ARENA (64 * 1024 * 1024)
#define COMPILE_ZONE_SIZE (64 * 1024 * 1024)
#define DEFAULT_ARENA (8 * 1024 * 1024)
#define COMPILE_ZONE_SIZE (8 * 1024 * 1024)
#define STACK_SIZE (2 * 1024 * 1024)
#include "memory.h"

1
native/gc.c
View File

@ -69,6 +69,7 @@ INLINE void collect_object(CELL scan)
collect_word((F_WORD*)scan);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
collect_array((F_ARRAY*)scan);
break;
case HASHTABLE_TYPE:

2
native/hashtable.c
View File

@ -7,7 +7,7 @@ F_HASHTABLE* hashtable(F_FIXNUM capacity)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR));
hash->count = tag_fixnum(0);
hash->array = tag_object(array(capacity,F));
hash->array = tag_object(array(ARRAY_TYPE,capacity,F));
return hash;
}

3
native/primitives.c
View File

@ -175,7 +175,8 @@ void* primitives[] = {
primitive_set_integer_slot,
primitive_grow_array,
primitive_hashtable,
primitive_array
primitive_array,
primitive_tuple
};
CELL primitive_to_xt(CELL primitive)

1
native/relocate.c
View File

@ -8,6 +8,7 @@ void relocate_object(CELL relocating)
fixup_word((F_WORD*)relocating);
break;
case ARRAY_TYPE:
case TUPLE_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
case HASHTABLE_TYPE:

1
native/types.c
View File

@ -53,6 +53,7 @@ CELL untagged_object_size(CELL pointer)
break;
case ARRAY_TYPE:
case BIGNUM_TYPE:
case TUPLE_TYPE:
size = ASIZE(pointer);
break;
case HASHTABLE_TYPE:

5
native/types.h
View File

@ -12,7 +12,7 @@
#define RATIO_TYPE 4
#define FLOAT_TYPE 5
#define COMPLEX_TYPE 6
#define HEADER_TYPE 7
#define HEADER_TYPE 7 /* anything less than this is a tag */
#define GC_COLLECTED 7 /* See gc.c */
/*** Header types ***/
@ -35,8 +35,9 @@ CELL T;
#define DLL_TYPE 15
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define TUPLE_TYPE 18
#define TYPE_COUNT 18
#define TYPE_COUNT 19
INLINE bool headerp(CELL cell)
{

2
native/vector.c
View File

@ -7,7 +7,7 @@ F_VECTOR* vector(F_FIXNUM capacity)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
vector->top = tag_fixnum(0);
vector->array = tag_object(array(capacity,F));
vector->array = tag_object(array(ARRAY_TYPE,capacity,F));
return vector;
}