From dd1b0a0b2b52055bddda1a2df6c02d274683b3ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Feb 2005 01:37:01 +0000 Subject: [PATCH] 0.72 ready for release --- Makefile | 3 +- TODO.FACTOR.txt | 3 +- library/bootstrap/boot-stage2.factor | 2 +- library/bootstrap/boot.factor | 5 +- library/bootstrap/primitives.factor | 4 +- library/generic/builtin.factor | 50 +---------- library/generic/complement.factor | 46 +--------- library/generic/generic.factor | 21 ----- library/generic/null.factor | 32 +------ library/generic/object.factor | 40 +-------- library/generic/predicate.factor | 48 +---------- library/generic/tuple.factor | 19 +---- library/generic/union.factor | 48 +---------- library/syntax/generic.factor | 68 +++++++++++++++ .../{heap-stats.factor => memory.factor} | 16 ++++ native/factor.h | 1 - native/memory.c | 54 +++++++++++- native/memory.h | 19 +++-- native/primitives.c | 4 +- native/scan.c | 84 ------------------- native/scan.h | 51 ----------- 21 files changed, 184 insertions(+), 434 deletions(-) create mode 100644 library/syntax/generic.factor rename library/tools/{heap-stats.factor => memory.factor} (75%) delete mode 100644 native/scan.c delete mode 100644 native/scan.h diff --git a/Makefile b/Makefile index d44483531a..45e4277e61 100644 --- a/Makefile +++ b/Makefile @@ -22,8 +22,7 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \ native/word.o native/compiler.o \ native/ffi.o native/boolean.o \ native/debug.o \ - native/hashtable.o \ - native/scan.o + native/hashtable.o default: @echo "Run 'make' with one of the following parameters:" diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 6c4a2b9f9f..9a04a1a332 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -20,8 +20,7 @@ - #jump-f #jump-f-label - extract word inside M:, C:, and structure browsing for these - fix checkbox alignment -- begin-scan, next-object, end-scan primitives -- each-object, each-slot combinators +- each-slot combinator - references primitive - resize window: world not updated until mouse moved - x>offset diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 8fd5920415..be61d3505b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -54,7 +54,7 @@ USING: kernel lists parser stdio words namespaces ; "/library/io/files.factor" "/library/eval-catch.factor" - "/library/tools/heap-stats.factor" + "/library/tools/memory.factor" "/library/tools/listener.factor" "/library/cli.factor" ] [ diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index dc22e2a20a..e0b2c92d05 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -38,6 +38,8 @@ words hashtables ; "/library/syntax/parse-numbers.factor" parse-resource append, "/library/syntax/parser.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 "object" [ "generic" ] search @@ -46,7 +48,7 @@ words hashtables ; reveal reveal - + "/library/generic/generic.factor" parse-resource append, "/library/generic/object.factor" parse-resource append, "/library/generic/null.factor" parse-resource append, @@ -57,7 +59,6 @@ words hashtables ; "/library/generic/tuple.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, - "/library/syntax/parse-syntax.factor" parse-resource append, ] make-list "boot" [ "kernel" ] search swons diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 4364f7fcfb..cacc1a04e5 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -179,7 +179,6 @@ vocabularies get [ [ "set-alien-2" "alien" [ [ integer alien integer ] [ ] ] ] [ "alien-1" "alien" [ [ alien integer ] [ fixnum ] ] ] [ "set-alien-1" "alien" [ [ integer alien integer ] [ ] ] ] - [ "heap-stats" "memory" [ [ ] [ general-list ] ] ] [ "throw" "errors" [ [ object ] [ ] ] ] [ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ] [ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ] @@ -202,7 +201,8 @@ vocabularies get [ [ ">tuple" "kernel-internals" [ [ object ] [ tuple ] ] ] [ "begin-scan" "memory" [ [ ] [ ] ] ] [ "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> dup string? [ diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index d61dc5369d..80e85df1be 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -1,40 +1,8 @@ -! :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: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors +USING: errors hashtables kernel lists namespaces parser strings +words vectors ; ! Builtin metaclass for builtin types: fixnum, word, cons, etc. SYMBOL: builtin @@ -75,15 +43,5 @@ builtin [ 2drop t ] "class<" set-word-property [ swap "builtin-type" set-word-property ] keep 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 ) unit classes get hash ; - -M: object class ( obj -- class ) - #! Analogous to the type primitive. Pushes the builtin - #! class of an object. - type builtin-type ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index 26bd8e3f62..67e144243b 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -1,41 +1,9 @@ -! :folding=indent: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. +! See http://factor.sf.net/license.txt for BSD license. IN: generic -USE: errors -USE: hashtables -USE: kernel -USE: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors -USE: math +USING: errors hashtables kernel lists math parser strings +vectors words ; ! Complement metaclass, contains all objects not in a certain class. SYMBOL: complement @@ -71,11 +39,3 @@ complement [ [ complement-predicate define-compound ] keep dupd "complement" set-word-property 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 diff --git a/library/generic/generic.factor b/library/generic/generic.factor index a7f39e2e72..ff59d445f4 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -92,30 +92,11 @@ namespaces parser strings words vectors math math-internals ; : 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: CREATE define-generic ; parsing - : arithmetic-combination ( n n vtable -- ) #! Note that the numbers remain on the stack, possibly after #! being coerced to a maximal type. >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. SYMBOL: classes @@ -162,5 +143,3 @@ SYMBOL: object classes get set-hash ; classes get [ classes set ] unless - -GENERIC: class ( obj -- class ) diff --git a/library/generic/null.factor b/library/generic/null.factor index d6c9f6c5d9..b88c09b54c 100644 --- a/library/generic/null.factor +++ b/library/generic/null.factor @@ -1,33 +1,7 @@ -! :folding=indent: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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: generic -USE: kernel -USE: words +USING: kernel words ; ! Null metaclass with no instances. SYMBOL: null diff --git a/library/generic/object.factor b/library/generic/object.factor index 7802599697..0e7231551c 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -1,41 +1,7 @@ -! :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: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors -USE: math +USING: kernel lists math vectors words ; ! Catch-all metaclass for providing a default method. SYMBOL: object diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index d9f0989aeb..520dcca2b1 100644 --- a/library/generic/predicate.factor +++ b/library/generic/predicate.factor @@ -1,40 +1,8 @@ -! :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. - +! See http://factor.sf.net/license.txt for BSD license. IN: generic -USE: errors -USE: hashtables -USE: kernel -USE: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors +USING: errors hashtables kernel lists namespaces parser strings +words vectors ; ! Predicate metaclass for generalized predicate dispatch. SYMBOL: predicate @@ -78,13 +46,3 @@ predicate [ [ \ dup , append, , [ drop f ] , \ ifte , ] make-list define-compound 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 diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 4d564f3feb..a6256c775b 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -4,6 +4,10 @@ IN: generic USING: words parser kernel namespaces lists strings 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 ) dup "tuple-size" word-property [ 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 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 ) dup tuple? [ dup class "delegate-field" word-property dup [ @@ -223,8 +214,6 @@ M: tuple hashcode ( vec -- n ) 1 swap array-nth hashcode ] ifte ; -M: tuple class ( obj -- class ) 2 slot ; - tuple [ ( generic vtable definition class -- ) 2drop add-tuple-dispatch diff --git a/library/generic/union.factor b/library/generic/union.factor index bca22d3859..453cf34ac7 100644 --- a/library/generic/union.factor +++ b/library/generic/union.factor @@ -1,40 +1,8 @@ -! :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: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors +USING: errors hashtables kernel lists namespaces parser strings +words vectors ; ! Union metaclass for dispatch on multiple classes. SYMBOL: union @@ -80,11 +48,3 @@ union [ 2drop t ] "class<" set-word-property [ union-predicate define-compound ] keep dupd "members" set-word-property 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 diff --git a/library/syntax/generic.factor b/library/syntax/generic.factor new file mode 100644 index 0000000000..6aa102e6d0 --- /dev/null +++ b/library/syntax/generic.factor @@ -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 diff --git a/library/tools/heap-stats.factor b/library/tools/memory.factor similarity index 75% rename from library/tools/heap-stats.factor rename to library/tools/memory.factor index 90dd574d54..3657e7193b 100644 --- a/library/tools/heap-stats.factor +++ b/library/tools/memory.factor @@ -45,6 +45,22 @@ stdio unparser vectors words ; ] each-object drop ] 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 -- ) dup 0 = [ 3drop diff --git a/native/factor.h b/native/factor.h index 5b9de43071..1dfe205034 100644 --- a/native/factor.h +++ b/native/factor.h @@ -127,6 +127,5 @@ typedef unsigned char BYTE; #include "relocate.h" #include "ffi.h" #include "debug.h" -#include "scan.h" #endif /* __FACTOR_H__ */ diff --git a/native/memory.c b/native/memory.c index 21b739e82e..c8a8bf55a6 100644 --- a/native/memory.c +++ b/native/memory.c @@ -118,5 +118,57 @@ void primitive_allot_profiling(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; } diff --git a/native/memory.h b/native/memory.h index 8b1c357197..cb7657b6b8 100644 --- a/native/memory.h +++ b/native/memory.h @@ -66,9 +66,16 @@ bool in_zone(ZONE* z, CELL pointer); void primitive_room(void); void primitive_allot_profiling(void); void primitive_address(void); -void primitive_memory_cell(void); -void primitive_memory_4(void); -void primitive_memory_1(void); -void primitive_set_memory_cell(void); -void primitive_set_memory_4(void); -void primitive_set_memory_1(void); +void primitive_size(void); + +/* 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; + +void primitive_begin_scan(void); +void primitive_next_object(void); +void primitive_end_scan(void); diff --git a/native/primitives.c b/native/primitives.c index f84b55328c..5964a17712 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -158,7 +158,6 @@ void* primitives[] = { primitive_set_alien_2, primitive_alien_1, primitive_set_alien_1, - primitive_heap_stats, primitive_throw, primitive_string_to_memory, primitive_memory_to_string, @@ -181,7 +180,8 @@ void* primitives[] = { primitive_to_tuple, primitive_begin_scan, primitive_next_object, - primitive_end_scan + primitive_end_scan, + primitive_size }; CELL primitive_to_xt(CELL primitive) diff --git a/native/scan.c b/native/scan.c deleted file mode 100644 index 94581f5726..0000000000 --- a/native/scan.c +++ /dev/null @@ -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); -} diff --git a/native/scan.h b/native/scan.h deleted file mode 100644 index a213dadd55..0000000000 --- a/native/scan.h +++ /dev/null @@ -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);