Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
2e0e061790
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel kernel.private math namespaces
|
||||
sequences strings words effects combinators alien.c-types ;
|
||||
IN: alien.structs.fields
|
||||
|
||||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-effect ( type spec -- effect )
|
||||
[ 1array ] [ name>> 1array ] bi* <effect> ;
|
||||
|
||||
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
|
||||
|
||||
: set-reader-props ( class spec -- )
|
||||
2dup reader-effect
|
||||
over reader>>
|
||||
swap "declared-effect" set-word-prop
|
||||
reader>> swap "reading" set-word-prop ;
|
||||
|
||||
: writer-effect ( type spec -- effect )
|
||||
name>> swap 2array 0 <effect> ;
|
||||
|
||||
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
||||
|
||||
: set-writer-props ( class spec -- )
|
||||
2dup writer-effect
|
||||
over writer>>
|
||||
swap "declared-effect" set-word-prop
|
||||
writer>> swap "writing" set-word-prop ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
>r >r "-" r> 3append r> create ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
>r [ swap "set-" % % "-" % % ] "" make r> create ;
|
||||
|
||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||
field-spec new
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>type
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
||||
: align-offset ( offset type -- offset )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( specs -- size )
|
||||
0 [
|
||||
[ type>> align-offset ] keep
|
||||
[ (>>offset) ] [ type>> heap-size + ] 2bi
|
||||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( spec word quot -- )
|
||||
rot offset>> prefix define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ ]
|
||||
[ reader>> ]
|
||||
[
|
||||
type>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
[ ]
|
||||
[ writer>> ]
|
||||
[ type>> c-setter ] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
[ define-getter ] [ define-setter ] 2bi ;
|
||||
|
|
@ -1,75 +1,7 @@
|
|||
IN: alien.structs
|
||||
USING: accessors alien.c-types strings help.markup help.syntax
|
||||
alien.syntax sequences io arrays slots.deprecated
|
||||
kernel words slots assocs namespaces accessors ;
|
||||
|
||||
! Deprecated code
|
||||
: ($spec-reader-values) ( slot-spec class -- element )
|
||||
dup ?word-name swap 2array
|
||||
over name>>
|
||||
rot class>> 2array 2array
|
||||
[ { $instance } swap suffix ] assoc-map ;
|
||||
|
||||
: $spec-reader-values ( slot-spec class -- )
|
||||
($spec-reader-values) $values ;
|
||||
|
||||
: $spec-reader-description ( slot-spec class -- )
|
||||
[
|
||||
"Outputs the value stored in the " ,
|
||||
{ $snippet } rot name>> suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
: slot-of-reader ( reader specs -- spec/f )
|
||||
[ reader>> eq? ] with find nip ;
|
||||
|
||||
: $spec-reader ( reader slot-specs class -- )
|
||||
>r slot-of-reader r>
|
||||
over [
|
||||
2dup $spec-reader-values
|
||||
2dup $spec-reader-description
|
||||
] when 2drop ;
|
||||
|
||||
GENERIC: slot-specs ( help-type -- specs )
|
||||
|
||||
M: word slot-specs "slots" word-prop ;
|
||||
|
||||
: $slot-reader ( reader -- )
|
||||
first dup "reading" word-prop [ slot-specs ] keep
|
||||
$spec-reader ;
|
||||
|
||||
: $spec-writer-values ( slot-spec class -- )
|
||||
($spec-reader-values) reverse $values ;
|
||||
|
||||
: $spec-writer-description ( slot-spec class -- )
|
||||
[
|
||||
"Stores a new value to the " ,
|
||||
{ $snippet } rot name>> suffix ,
|
||||
" slot of " ,
|
||||
{ $instance } swap suffix ,
|
||||
" instance." ,
|
||||
] { } make $description ;
|
||||
|
||||
: slot-of-writer ( writer specs -- spec/f )
|
||||
[ writer>> eq? ] with find nip ;
|
||||
|
||||
: $spec-writer ( writer slot-specs class -- )
|
||||
>r slot-of-writer r>
|
||||
over [
|
||||
2dup $spec-writer-values
|
||||
2dup $spec-writer-description
|
||||
dup ?word-name 1array $side-effects
|
||||
] when 2drop ;
|
||||
|
||||
: $slot-writer ( reader -- )
|
||||
first dup "writing" word-prop [ slot-specs ] keep
|
||||
$spec-writer ;
|
||||
|
||||
M: string slot-specs c-type fields>> ;
|
||||
|
||||
M: array ($instance) first ($instance) " array" write ;
|
||||
alien.syntax sequences io arrays kernel words assocs namespaces
|
||||
accessors ;
|
||||
IN: alien.structs
|
||||
|
||||
ARTICLE: "c-structs" "C structure types"
|
||||
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
||||
|
|
|
|||
|
|
@ -1,43 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc slots
|
||||
slots.deprecated alien.c-types cpu.architecture ;
|
||||
math namespaces parser sequences strings words libc
|
||||
alien.c-types alien.structs.fields cpu.architecture ;
|
||||
IN: alien.structs
|
||||
|
||||
: align-offset ( offset type -- offset )
|
||||
c-type-align align ;
|
||||
|
||||
: struct-offsets ( specs -- size )
|
||||
0 [
|
||||
[ class>> align-offset ] keep
|
||||
[ (>>offset) ] 2keep
|
||||
class>> heap-size +
|
||||
] reduce ;
|
||||
|
||||
: define-struct-slot-word ( spec word quot -- )
|
||||
rot offset>> prefix define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ ]
|
||||
[ reader>> ]
|
||||
[
|
||||
class>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
[ ]
|
||||
[ writer>> ]
|
||||
[ class>> c-setter ] tri
|
||||
define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
2dup define-getter define-setter ;
|
||||
|
||||
: if-value-structs? ( ctype true false -- )
|
||||
value-structs?
|
||||
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
|
||||
|
|
@ -76,17 +43,8 @@ M: struct-type stack-size
|
|||
struct-type boa
|
||||
-rot define-c-type ;
|
||||
|
||||
: make-field ( struct-name vocab type field-name -- spec )
|
||||
<slot-spec>
|
||||
0 >>offset
|
||||
swap >>name
|
||||
swap expand-constants >>class
|
||||
3dup name>> swap reader-word >>reader
|
||||
3dup name>> swap writer-word >>writer
|
||||
2nip ;
|
||||
|
||||
: define-struct-early ( name vocab fields -- fields )
|
||||
-rot [ rot first2 make-field ] 2curry map ;
|
||||
-rot [ rot first2 <field-spec> ] 2curry map ;
|
||||
|
||||
: compute-struct-align ( types -- n )
|
||||
[ c-type-align ] map supremum ;
|
||||
|
|
@ -94,7 +52,7 @@ M: struct-type stack-size
|
|||
: define-struct ( name vocab fields -- )
|
||||
pick >r
|
||||
[ struct-offsets ] keep
|
||||
[ [ class>> ] map compute-struct-align ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
r> [ swap define-field ] curry each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@ SYMBOL: +failed+
|
|||
[
|
||||
dup crossref?
|
||||
[
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
dependencies get >alist
|
||||
generic-dependencies get >alist
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
|
|
|||
|
|
@ -178,7 +178,7 @@ stack-params "__stack_value" c-type (>>reg-class) >>
|
|||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ class>> ] [ offset>> ] bi 2array
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
|
|
|
|||
|
|
@ -10,14 +10,17 @@ IN: debugger.threads
|
|||
dup id>> #
|
||||
" (" % dup name>> %
|
||||
", " % dup quot>> unparse-short % ")" %
|
||||
] "" make swap write-object ":" print nl ;
|
||||
] "" make swap write-object ":" print ;
|
||||
|
||||
M: thread error-in-thread ( error thread -- )
|
||||
initial-thread get-global eq? [
|
||||
die drop
|
||||
] [
|
||||
global [
|
||||
error-thread get-global error-in-thread. print-error flush
|
||||
error-thread get-global error-in-thread. nl
|
||||
print-error nl
|
||||
:c
|
||||
flush
|
||||
] bind
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -89,8 +89,11 @@ SYMBOL: meta-r
|
|||
SYMBOL: dependencies
|
||||
|
||||
: depends-on ( word how -- )
|
||||
dependencies get dup
|
||||
[ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
|
||||
over primitive? [ 2drop ] [
|
||||
dependencies get dup [
|
||||
swap '[ , strongest-dependency ] change-at
|
||||
] [ 3drop ] if
|
||||
] if ;
|
||||
|
||||
! Generic words that the current quotation depends on
|
||||
SYMBOL: generic-dependencies
|
||||
|
|
|
|||
|
|
@ -62,10 +62,13 @@ TUPLE: check-mixin-class mixin ;
|
|||
] if-mixin-member? ;
|
||||
|
||||
: remove-mixin-instance ( class mixin -- )
|
||||
#! The order of the three clauses is important here. The last
|
||||
#! one must come after the other two so that the entries it
|
||||
#! adds to changed-generics are not overwritten.
|
||||
[
|
||||
[ class-usages update-methods ]
|
||||
[ [ swap remove ] change-mixin-class ]
|
||||
[ nip update-classes ]
|
||||
[ class-usages update-methods ]
|
||||
2tri
|
||||
] [ 2drop ] if-mixin-member? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -110,8 +110,7 @@ SYMBOL: update-tuples-hook
|
|||
: (compiled-generic-usages) ( generic class -- assoc )
|
||||
dup class? [
|
||||
[ compiled-generic-usage ] dip
|
||||
[ [ classes-intersect? ] [ null class<= ] bi or nip ]
|
||||
curry assoc-filter
|
||||
[ classes-intersect? nip ] curry assoc-filter
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: compiled-generic-usages ( assoc -- assocs )
|
||||
|
|
|
|||
|
|
@ -1,81 +0,0 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel kernel.private math namespaces
|
||||
sequences strings words effects generic generic.standard
|
||||
classes slots.private combinators slots ;
|
||||
IN: slots.deprecated
|
||||
|
||||
: reader-effect ( class spec -- effect )
|
||||
>r ?word-name 1array r> name>> 1array <effect> ;
|
||||
|
||||
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
|
||||
|
||||
: set-reader-props ( class spec -- )
|
||||
2dup reader-effect
|
||||
over reader>>
|
||||
swap "declared-effect" set-word-prop
|
||||
reader>> swap "reading" set-word-prop ;
|
||||
|
||||
: define-slot-word ( class word quot -- )
|
||||
[
|
||||
dup define-simple-generic
|
||||
create-method
|
||||
] dip define ;
|
||||
|
||||
: define-reader ( class spec -- )
|
||||
dup reader>> [
|
||||
[ set-reader-props ] 2keep
|
||||
dup reader>>
|
||||
swap reader-quot
|
||||
define-slot-word
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: writer-effect ( class spec -- effect )
|
||||
name>> swap ?word-name 2array 0 <effect> ;
|
||||
|
||||
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
||||
|
||||
: set-writer-props ( class spec -- )
|
||||
2dup writer-effect
|
||||
over writer>>
|
||||
swap "declared-effect" set-word-prop
|
||||
writer>> swap "writing" set-word-prop ;
|
||||
|
||||
: define-writer ( class spec -- )
|
||||
dup writer>> [
|
||||
[ set-writer-props ] 2keep
|
||||
dup writer>>
|
||||
swap writer-quot
|
||||
define-slot-word
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: define-slot ( class spec -- )
|
||||
2dup define-reader define-writer ;
|
||||
|
||||
: define-slots ( class specs -- )
|
||||
[ define-slot ] with each ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
>r >r "-" r> 3append r> create ;
|
||||
|
||||
: writer-word ( class name vocab -- word )
|
||||
>r [ swap "set-" % % "-" % % ] "" make r> create ;
|
||||
|
||||
: (simple-slot-word) ( class name -- class name vocab )
|
||||
over vocabulary>> >r >r name>> r> r> ;
|
||||
|
||||
: simple-reader-word ( class name -- word )
|
||||
(simple-slot-word) reader-word ;
|
||||
|
||||
: simple-writer-word ( class name -- word )
|
||||
(simple-slot-word) writer-word ;
|
||||
|
||||
: deprecated-slots ( class slot-specs -- slot-specs' )
|
||||
[
|
||||
2dup name>> simple-reader-word >>reader
|
||||
2dup name>> simple-writer-word >>writer
|
||||
] map nip ;
|
||||
|
|
@ -6,7 +6,7 @@ classes.algebra slots.private combinators accessors words
|
|||
sequences.private assocs alien ;
|
||||
IN: slots
|
||||
|
||||
TUPLE: slot-spec name offset class initial read-only reader writer ;
|
||||
TUPLE: slot-spec name offset class initial read-only ;
|
||||
|
||||
PREDICATE: reader < word "reader" word-prop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
IN: benchmark.euler150
|
||||
USE: project-euler.150
|
||||
USING: kernel project-euler.150 ;
|
||||
|
||||
MAIN: euler150
|
||||
: euler150-benchmark ( -- )
|
||||
euler150 -271248680 assert= ;
|
||||
|
||||
MAIN: euler150-benchmark
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
IN: benchmark.euler186
|
||||
USE: project-euler.186
|
||||
USING: kernel project-euler.186 ;
|
||||
|
||||
MAIN: euler186
|
||||
: euler186-benchmark ( -- )
|
||||
euler186 2325629 assert= ;
|
||||
|
||||
MAIN: euler186-benchmark
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: benchmark.typecheck4
|
|||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: hello-n* ( obj -- val ) 3 slot ;
|
||||
: hello-n* ( obj -- val ) 2 slot ;
|
||||
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
math
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
math
|
||||
unportable
|
||||
|
|
|
|||
Loading…
Reference in New Issue