- maple-like: press enter at old commands to evaluate there\r
- completion in the listener\r
- special completion for USE:/IN:\r
+- support USING:\r
\r
+ i/o:\r
\r
/*
* $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:
for(;;)
{
Object next = reader.next(false,false);
- if(next == null)
+ if(next == FactorScanner.EOF)
reader.getScanner().error("Expected ;");
if(next.equals(";"))
break;
-! :folding=indent:collapseFolds=1:\r
-\r
-! $Id$\r
-!\r
! Copyright (C) 2004, 2005 Slava Pestov.\r
-! \r
-! Redistribution and use in source and binary forms, with or without\r
-! modification, are permitted provided that the following conditions are met:\r
-! \r
-! 1. Redistributions of source code must retain the above copyright notice,\r
-! this list of conditions and the following disclaimer.\r
-! \r
-! 2. Redistributions in binary form must reproduce the above copyright notice,\r
-! this list of conditions and the following disclaimer in the documentation\r
-! and/or other materials provided with the distribution.\r
-! \r
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,\r
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND\r
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE\r
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\r
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,\r
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;\r
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,\r
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR\r
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF\r
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
-\r
-IN: init\r
-USE: kernel\r
-USE: lists\r
-USE: parser\r
-USE: stdio\r
-USE: words\r
-USE: namespaces\r
+! See http://factor.sf.net/license.txt for BSD license.\r
+USING: kernel lists parser stdio words namespaces ;\r
\r
"Cold boot in progress..." print\r
\r
"/library/generic/union.factor"\r
"/library/generic/complement.factor"\r
"/library/generic/traits.factor"\r
+ "/library/generic/tuple.factor"\r
\r
"/version.factor"\r
"/library/stack.factor"\r
-! :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
"/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,
-! :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
[[ "kernel-internals" "grow-array" ]]
[[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]]
+ [[ "kernel-internals" "<tuple>" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop
: 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 ;
-! :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 ;
! 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.
>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 [
] 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
: 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
#! 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
classes get set-hash ;
classes get [ <namespace> classes set ] unless
+
+GENERIC: class ( obj -- class )
] "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
--- /dev/null
+! 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
#! call it directly.
vector-array array-nth call ;
+BUILTIN: tuple 18
+
IN: kernel
GENERIC: hashcode ( obj -- n )
: 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.
: append, ( list -- )
[ , ] each ;
+
+: literal, ( word -- )
+ #! Append some code that pushes the word on the stack. Used
+ #! when building quotations.
+ unit , \ car , ;
[ grow-array [ [ integer array ] [ object ] ] ]
[ <hashtable> [ [ number ] [ hashtable ] ] ]
[ <array> [ [ number ] [ array ] ] ]
+ [ <tuple> [ [ number ] [ tuple ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property
: vector-benchmark ( n -- )
0 <vector> over fill-vector rot copy-vector ; compiled
-[ ] [ 4000000 vector-benchmark ] unit-test
+[ ] [ 400000 vector-benchmark ] unit-test
}
/* 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);
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)
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);
}
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);
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"
collect_word((F_WORD*)scan);
break;
case ARRAY_TYPE:
+ case TUPLE_TYPE:
collect_array((F_ARRAY*)scan);
break;
case HASHTABLE_TYPE:
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;
}
primitive_set_integer_slot,
primitive_grow_array,
primitive_hashtable,
- primitive_array
+ primitive_array,
+ primitive_tuple
};
CELL primitive_to_xt(CELL primitive)
fixup_word((F_WORD*)relocating);
break;
case ARRAY_TYPE:
+ case TUPLE_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
case HASHTABLE_TYPE:
break;
case ARRAY_TYPE:
case BIGNUM_TYPE:
+ case TUPLE_TYPE:
size = ASIZE(pointer);
break;
case HASHTABLE_TYPE:
#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 ***/
#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)
{
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;
}
projects / factor.git / commitdiff