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

0.72 ready for release

cvs
Slava Pestov 2005-02-19 01:37:01 +00:00
parent 9aaa9b0d1d
commit dd1b0a0b2b
21 changed files with 184 additions and 434 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -22,8 +22,7 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/word.o native/compiler.o \ native/word.o native/compiler.o \
native/ffi.o native/boolean.o \ native/ffi.o native/boolean.o \
native/debug.o \ native/debug.o \
native/hashtable.o \ native/hashtable.o
native/scan.o
default: default:
@echo "Run 'make' with one of the following parameters:" @echo "Run 'make' with one of the following parameters:"

3
TODO.FACTOR.txt
View File

@ -20,8 +20,7 @@
- #jump-f #jump-f-label - #jump-f #jump-f-label
- extract word inside M:, C:, and structure browsing for these - extract word inside M:, C:, and structure browsing for these
- fix checkbox alignment - fix checkbox alignment
- begin-scan, next-object, end-scan primitives - each-slot combinator
- each-object, each-slot combinators
- references primitive - references primitive
- resize window: world not updated until mouse moved - resize window: world not updated until mouse moved
- x>offset - x>offset

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

@ -54,7 +54,7 @@ USING: kernel lists parser stdio words namespaces ;
"/library/io/files.factor" "/library/io/files.factor"
"/library/eval-catch.factor" "/library/eval-catch.factor"
"/library/tools/heap-stats.factor" "/library/tools/memory.factor"
"/library/tools/listener.factor" "/library/tools/listener.factor"
"/library/cli.factor" "/library/cli.factor"
] [ ] [

3
library/bootstrap/boot.factor
View File

@ -38,6 +38,8 @@ words hashtables ;
"/library/syntax/parse-numbers.factor" parse-resource append, "/library/syntax/parse-numbers.factor" parse-resource append,
"/library/syntax/parser.factor" parse-resource append, "/library/syntax/parser.factor" parse-resource append,
"/library/syntax/parse-stream.factor" parse-resource append, "/library/syntax/parse-stream.factor" parse-resource append,
"/library/syntax/generic.factor" parse-resource append,
"/library/syntax/parse-syntax.factor" parse-resource append,
"delegate" [ "generic" ] search "delegate" [ "generic" ] search
"object" [ "generic" ] search "object" [ "generic" ] search
@ -57,7 +59,6 @@ words hashtables ;
"/library/generic/tuple.factor" parse-resource append, "/library/generic/tuple.factor" parse-resource append,
"/library/bootstrap/init.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append,
"/library/syntax/parse-syntax.factor" parse-resource append,
] make-list ] make-list
"boot" [ "kernel" ] search swons "boot" [ "kernel" ] search swons

2
library/bootstrap/primitives.factor
View File

@ -179,7 +179,6 @@ vocabularies get [
[ "set-alien-2" "alien" [ [ integer alien integer ] [ ] ] ] [ "set-alien-2" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-1" "alien" [ [ alien integer ] [ fixnum ] ] ] [ "alien-1" "alien" [ [ alien integer ] [ fixnum ] ] ]
[ "set-alien-1" "alien" [ [ integer alien integer ] [ ] ] ] [ "set-alien-1" "alien" [ [ integer alien integer ] [ ] ] ]
[ "heap-stats" "memory" [ [ ] [ general-list ] ] ]
[ "throw" "errors" [ [ object ] [ ] ] ] [ "throw" "errors" [ [ object ] [ ] ] ]
[ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ] [ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ]
[ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ] [ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ]
@ -203,6 +202,7 @@ vocabularies get [
[ "begin-scan" "memory" [ [ ] [ ] ] ] [ "begin-scan" "memory" [ [ ] [ ] ] ]
[ "next-object" "memory" [ [ ] [ object ] ] ] [ "next-object" "memory" [ [ ] [ object ] ] ]
[ "end-scan" "memory" [ [ ] [ object ] ] ] [ "end-scan" "memory" [ [ ] [ object ] ] ]
[ "size" "memory" [ [ ] [ object ] ] ]
] [ ] [
3unlist >r create >r 1 + r> 2dup swap f define r> 3unlist >r create >r 1 + r> 2dup swap f define r>
dup string? [ dup string? [

50
library/generic/builtin.factor
View File

@ -1,40 +1,8 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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: generic IN: generic
USE: errors USING: errors hashtables kernel lists namespaces parser strings
USE: hashtables words vectors ;
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
! Builtin metaclass for builtin types: fixnum, word, cons, etc. ! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin SYMBOL: builtin
@ -75,15 +43,5 @@ builtin [ 2drop t ] "class<" set-word-property
[ swap "builtin-type" set-word-property ] keep [ swap "builtin-type" set-word-property ] keep
builtin define-class ; builtin define-class ;
: BUILTIN:
#! Followed by type name and type number. Define a built-in
#! type predicate with this number.
CREATE scan-word swap builtin-class ; parsing
: builtin-type ( n -- symbol ) : builtin-type ( n -- symbol )
unit classes get hash ; unit classes get hash ;
M: object class ( obj -- class )
#! Analogous to the type primitive. Pushes the builtin
#! class of an object.
type builtin-type ;

46
library/generic/complement.factor
View File

@ -1,41 +1,9 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! 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: generic IN: generic
USE: errors USING: errors hashtables kernel lists math parser strings
USE: hashtables vectors words ;
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
USE: math
! Complement metaclass, contains all objects not in a certain class. ! Complement metaclass, contains all objects not in a certain class.
SYMBOL: complement SYMBOL: complement
@ -71,11 +39,3 @@ complement [
[ complement-predicate define-compound ] keep [ complement-predicate define-compound ] keep
dupd "complement" set-word-property dupd "complement" set-word-property
complement define-class ; complement define-class ;
: COMPLEMENT: ( -- class predicate definition )
#! Followed by a class name, then a complemented class.
CREATE
dup intern-symbol
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
scan-word define-complement ; parsing

21
library/generic/generic.factor
View File

@ -92,30 +92,11 @@ namespaces parser strings words vectors math math-internals ;
: single-combination ( obj vtable -- ) : single-combination ( obj vtable -- )
>r dup type r> dispatch ; inline >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: CREATE define-generic ; parsing
: arithmetic-combination ( n n vtable -- ) : arithmetic-combination ( n n vtable -- )
#! Note that the numbers remain on the stack, possibly after #! Note that the numbers remain on the stack, possibly after
#! being coerced to a maximal type. #! being coerced to a maximal type.
>r arithmetic-type r> dispatch ; inline >r arithmetic-type r> dispatch ; inline
: 2GENERIC:
#! 2GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:. 2GENERIC words dispatch on
#! arithmetic types and should not be used for non-numerical
#! types.
[ 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 scan-word [ define-method ] [ ] ; parsing
! Maps lists of builtin type numbers to class objects. ! Maps lists of builtin type numbers to class objects.
SYMBOL: classes SYMBOL: classes
@ -162,5 +143,3 @@ SYMBOL: object
classes get set-hash ; classes get set-hash ;
classes get [ <namespace> classes set ] unless classes get [ <namespace> classes set ] unless
GENERIC: class ( obj -- class )

32
library/generic/null.factor
View File

@ -1,33 +1,7 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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.
IN: generic IN: generic
USE: kernel USING: kernel words ;
USE: words
! Null metaclass with no instances. ! Null metaclass with no instances.
SYMBOL: null SYMBOL: null

40
library/generic/object.factor
View File

@ -1,41 +1,7 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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: generic IN: generic
USE: errors USING: kernel lists math vectors words ;
USE: hashtables
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
USE: math
! Catch-all metaclass for providing a default method. ! Catch-all metaclass for providing a default method.
SYMBOL: object SYMBOL: object

48
library/generic/predicate.factor
View File

@ -1,40 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! 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: generic IN: generic
USE: errors USING: errors hashtables kernel lists namespaces parser strings
USE: hashtables words vectors ;
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
! Predicate metaclass for generalized predicate dispatch. ! Predicate metaclass for generalized predicate dispatch.
SYMBOL: predicate SYMBOL: predicate
@ -78,13 +46,3 @@ predicate [
[ \ dup , append, , [ drop f ] , \ ifte , ] make-list [ \ dup , append, , [ drop f ] , \ ifte , ] make-list
define-compound define-compound
predicate "metaclass" set-word-property ; predicate "metaclass" set-word-property ;
: PREDICATE: ( -- class predicate definition )
#! Followed by a superclass name, then a class name.
scan-word
CREATE dup intern-symbol
dup rot "superclass" set-word-property
dup predicate-word
! 2dup swap "predicate" set-word-property
[ dupd unit "predicate" set-word-property ] keep
[ define-predicate ] [ ] ; parsing

19
library/generic/tuple.factor
View File

@ -4,6 +4,10 @@ IN: generic
USING: words parser kernel namespaces lists strings USING: words parser kernel namespaces lists strings
kernel-internals math hashtables errors vectors ; kernel-internals math hashtables errors vectors ;
: class ( obj -- class )
#! The class of an object.
dup tuple? [ 2 slot ] [ type builtin-type ] ifte ;
: make-tuple ( class -- tuple ) : make-tuple ( class -- tuple )
dup "tuple-size" word-property <tuple> dup "tuple-size" word-property <tuple>
[ 0 swap set-array-nth ] keep ; [ 0 swap set-array-nth ] keep ;
@ -106,19 +110,6 @@ kernel-internals math hashtables errors vectors ;
dup r> define-slots "slot-words" set-word-property dup r> define-slots "slot-words" set-word-property
default-constructor ; default-constructor ;
: TUPLE:
#! Followed by a tuple name, then slot names, then ;
scan
string-mode on
[ string-mode off define-tuple ]
f ; parsing
: C:
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
#! stack.
scan-word [ define-constructor ] f ; parsing
: tuple-delegate ( tuple -- obj ) : tuple-delegate ( tuple -- obj )
dup tuple? [ dup tuple? [
dup class "delegate-field" word-property dup [ dup class "delegate-field" word-property dup [
@ -223,8 +214,6 @@ M: tuple hashcode ( vec -- n )
1 swap array-nth hashcode 1 swap array-nth hashcode
] ifte ; ] ifte ;
M: tuple class ( obj -- class ) 2 slot ;
tuple [ tuple [
( generic vtable definition class -- ) ( generic vtable definition class -- )
2drop add-tuple-dispatch 2drop add-tuple-dispatch

48
library/generic/union.factor
View File

@ -1,40 +1,8 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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: generic IN: generic
USE: errors USING: errors hashtables kernel lists namespaces parser strings
USE: hashtables words vectors ;
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
! Union metaclass for dispatch on multiple classes. ! Union metaclass for dispatch on multiple classes.
SYMBOL: union SYMBOL: union
@ -80,11 +48,3 @@ union [ 2drop t ] "class<" set-word-property
[ union-predicate define-compound ] keep [ union-predicate define-compound ] keep
dupd "members" set-word-property dupd "members" set-word-property
union define-class ; union define-class ;
: UNION: ( -- class predicate definition )
#! Followed by a class name, then a list of union members.
CREATE
dup intern-symbol
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
[ define-union ] [ ] ; parsing

68
library/syntax/generic.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Bootstrapping trick; see doc/bootstrap.txt.
IN: !syntax
USING: syntax generic kernel lists namespaces parser words ;
: GENERIC:
#! GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:.
[ single-combination ]
\ GENERIC: CREATE define-generic ; parsing
: 2GENERIC:
#! 2GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:. 2GENERIC words dispatch on
#! arithmetic types and should not be used for non-numerical
#! types.
[ arithmetic-combination ]
\ 2GENERIC: CREATE define-generic ; parsing
: BUILTIN:
#! Followed by type name and type number. Define a built-in
#! type predicate with this number.
CREATE scan-word swap builtin-class ; parsing
: COMPLEMENT: ( -- class predicate definition )
#! Followed by a class name, then a complemented class.
CREATE
dup intern-symbol
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
scan-word define-complement ; parsing
: UNION: ( -- class predicate definition )
#! Followed by a class name, then a list of union members.
CREATE
dup intern-symbol
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
[ define-union ] [ ] ; parsing
: PREDICATE: ( -- class predicate definition )
#! Followed by a superclass name, then a class name.
scan-word
CREATE dup intern-symbol
dup rot "superclass" set-word-property
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
[ define-predicate ] [ ] ; parsing
: TUPLE:
#! Followed by a tuple name, then slot names, then ;
scan
string-mode on
[ string-mode off define-tuple ]
f ; parsing
: M: ( -- class generic [ ] )
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
scan-word scan-word [ define-method ] [ ] ; parsing
: C:
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
#! stack.
scan-word [ define-constructor ] f ; parsing

16
library/tools/heap-stats.factor → library/tools/memory.factor
View File

@ -45,6 +45,22 @@ stdio unparser vectors words ;
] each-object drop ] each-object drop
] make-list ; ] make-list ;
: vector+ ( n index vector -- )
[ vector-nth + ] 2keep set-vector-nth ;
: heap-stat-step ( counts sizes obj -- )
[ dup size swap type rot vector+ ] keep
1 swap type rot vector+ ;
: zero-vector ( n -- vector )
[ drop 0 ] vector-project ;
: heap-stats ( -- stats )
#! Return a list of instance count/total size pairs.
num-types zero-vector num-types zero-vector
[ >r 2dup r> heap-stat-step ] each-object
swap vector>list swap vector>list zip ;
: heap-stat. ( type instances bytes -- ) : heap-stat. ( type instances bytes -- )
dup 0 = [ dup 0 = [
3drop 3drop

1
native/factor.h
View File

@ -127,6 +127,5 @@ typedef unsigned char BYTE;
#include "relocate.h" #include "relocate.h"
#include "ffi.h" #include "ffi.h"
#include "debug.h" #include "debug.h"
#include "scan.h"
#endif /* __FACTOR_H__ */ #endif /* __FACTOR_H__ */

54
native/memory.c
View File

@ -118,5 +118,57 @@ void primitive_allot_profiling(void)
void primitive_address(void) void primitive_address(void)
{ {
dpush(tag_bignum(s48_ulong_to_bignum(dpop()))); drepl(tag_bignum(s48_ulong_to_bignum(dpeek())));
}
void primitive_size(void)
{
drepl(tag_fixnum(object_size(dpeek())));
}
void primitive_begin_scan(void)
{
primitive_gc();
heap_scan_ptr = active.base;
heap_scan_end = active.here;
heap_scan = true;
}
void primitive_next_object(void)
{
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL size, type;
if(!heap_scan)
general_error(ERROR_HEAP_SCAN,F);
if(heap_scan_ptr >= heap_scan_end)
{
dpush(F);
return;
}
if(headerp(value))
{
size = align8(untagged_object_size(heap_scan_ptr));
type = untag_header(value);
}
else
{
size = CELLS * 2;
type = CONS_TYPE;
}
heap_scan_ptr += size;
if(type < HEADER_TYPE)
dpush(RETAG(obj,type));
else
dpush(RETAG(obj,OBJECT_TYPE));
}
void primitive_end_scan(void)
{
heap_scan = false;
} }

19
native/memory.h
View File

@ -66,9 +66,16 @@ bool in_zone(ZONE* z, CELL pointer);
void primitive_room(void); void primitive_room(void);
void primitive_allot_profiling(void); void primitive_allot_profiling(void);
void primitive_address(void); void primitive_address(void);
void primitive_memory_cell(void); void primitive_size(void);
void primitive_memory_4(void);
void primitive_memory_1(void); /* A heap walk allows useful things to be done, like finding all
void primitive_set_memory_cell(void); references to an object for debugging purposes. */
void primitive_set_memory_4(void); CELL heap_scan_ptr;
void primitive_set_memory_1(void);
/* End of heap when walk was started; prevents infinite loop if
walk consing */
CELL heap_scan_end;
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);

4
native/primitives.c
View File

@ -158,7 +158,6 @@ void* primitives[] = {
primitive_set_alien_2, primitive_set_alien_2,
primitive_alien_1, primitive_alien_1,
primitive_set_alien_1, primitive_set_alien_1,
primitive_heap_stats,
primitive_throw, primitive_throw,
primitive_string_to_memory, primitive_string_to_memory,
primitive_memory_to_string, primitive_memory_to_string,
@ -181,7 +180,8 @@ void* primitives[] = {
primitive_to_tuple, primitive_to_tuple,
primitive_begin_scan, primitive_begin_scan,
primitive_next_object, primitive_next_object,
primitive_end_scan primitive_end_scan,
primitive_size
}; };
CELL primitive_to_xt(CELL primitive) CELL primitive_to_xt(CELL primitive)

84
native/scan.c
View File

@ -1,84 +0,0 @@
#include "factor.h"
void primitive_begin_scan(void)
{
primitive_gc();
heap_scan_ptr = active.base;
heap_scan_end = active.here;
heap_scan = true;
}
void primitive_next_object(void)
{
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL size, type;
if(!heap_scan)
general_error(ERROR_HEAP_SCAN,F);
if(heap_scan_ptr >= heap_scan_end)
{
dpush(F);
return;
}
if(headerp(value))
{
size = align8(untagged_object_size(heap_scan_ptr));
type = untag_header(value);
}
else
{
size = CELLS * 2;
type = CONS_TYPE;
}
heap_scan_ptr += size;
if(type < HEADER_TYPE)
dpush(RETAG(obj,type));
else
dpush(RETAG(obj,OBJECT_TYPE));
}
void primitive_end_scan(void)
{
heap_scan = false;
}
void primitive_heap_stats(void)
{
int instances[TYPE_COUNT], bytes[TYPE_COUNT];
int i;
CELL list = F;
for(i = 0; i < TYPE_COUNT; i++)
instances[i] = 0;
for(i = 0; i < TYPE_COUNT; i++)
bytes[i] = 0;
begin_heap_scan();
for(;;)
{
CELL size, type;
heap_step(&size,&type);
if(walk_donep())
break;
instances[type]++;
bytes[type] += size;
}
for(i = TYPE_COUNT - 1; i >= 0; i--)
{
list = cons(
cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
list);
}
dpush(list);
}

51
native/scan.h
View File

@ -1,51 +0,0 @@
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
CELL heap_scan_ptr;
/* End of heap when walk was started; prevents infinite loop if
walk consing */
CELL heap_scan_end;
/* Begin iterating through the heap. This is not re-entrant. */
INLINE void begin_heap_scan(void)
{
heap_scan_ptr = active.base;
}
INLINE CELL heap_step(CELL* size, CELL* type)
{
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
if(headerp(value))
{
*size = align8(untagged_object_size(heap_scan_ptr));
*type = untag_header(value);
}
else
{
*size = CELLS * 2;
*type = CONS_TYPE;
}
heap_scan_ptr += *size;
if(*type < HEADER_TYPE)
obj = RETAG(obj,*type);
else
obj = RETAG(obj,OBJECT_TYPE);
return obj;
}
INLINE bool walk_donep(void)
{
return (heap_scan_ptr >= active.here);
}
void primitive_heap_stats(void);
void primitive_instances(void);
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);