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

Merge branch 'master' of git://factorcode.org/git/factor

db4
U-FROGGER\erg 2008-03-26 03:04:06 -05:00
parent f368f4636b dfb638e30c
commit e50d77f6ba
92 changed files with 1580 additions and 1210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/alien.factor
View File

@ -7,7 +7,7 @@ IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: alien simple-alien
PREDICATE: simple-alien < alien
underlying-alien not ;
UNION: simple-c-ptr
@ -18,7 +18,7 @@ alien POSTPONE: f byte-array bit-array float-array ;
DEFER: pinned-c-ptr?
PREDICATE: alien pinned-alien
PREDICATE: pinned-alien < alien
underlying-alien pinned-c-ptr? ;
UNION: pinned-c-ptr

2
core/arrays/arrays.factor Normal file → Executable file
View File

@ -31,4 +31,4 @@ INSTANCE: array sequence
: 4array ( w x y z -- array ) { } 4sequence ; flushable
PREDICATE: array pair length 2 number= ;
PREDICATE: pair < array length 2 number= ;

11
core/assocs/assocs-tests.factor Normal file → Executable file
View File

@ -93,3 +93,14 @@ unit-test
] [
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
] unit-test
[ { 3 } ] [
[
3
H{ } clone
2 [
2dup [ , f ] cache
] times
2drop
] make
] unit-test

6
core/assocs/assocs.factor
View File

@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
(substitute) map ;
: cache ( key assoc quot -- value )
2over at [
2over at* [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-at
] if* ; inline
drop pick rot >r >r call dup r> r> set-at
] if ; inline
: change-at ( key assoc quot -- )
[ >r at r> call ] 3keep drop set-at ; inline

2
core/bootstrap/compiler/compiler.factor
View File

@ -36,7 +36,7 @@ nl
{
roll -roll declare not
tuple-class-eq? array? hashtable? vector?
array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth

39
core/bootstrap/image/image.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private
splitting growable classes tuples tuples.private words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
sequences.private combinators io.encodings.binary ;
@ -294,17 +294,14 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
: emit-tuple ( obj -- pointer )
! Tuples
: emit-tuple ( tuple -- pointer )
[
[ tuple>array unclip transfer-word , % ] { } make
tuple type-number dup emit-array
[
dup class transfer-word tuple-layout ' ,
tuple>array 1 tail-slice [ ' ] map %
] { } make
tuple type-number dup [ emit-seq ] emit-object
]
! Hack
over class word-name "tombstone" =
@ -312,11 +309,31 @@ M: float-array ' float-array emit-dummy-array ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
dup layout-hashcode ' ,
dup layout-class ' ,
dup layout-size ' ,
dup layout-superclasses ' ,
layout-echelon ' ,
] { } make
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first objects get [ emit-tuple ] cache ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
M: array '
array type-number object tag-number emit-array ;

5
core/bootstrap/layouts/layouts.factor
View File

@ -2,13 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts tuples ;
float-arrays quotations assocs layouts tuples tuples.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
19 num-types set
20 num-types set
H{
{ fixnum BIN: 000 }
@ -33,4 +33,5 @@ tag-numbers get H{
{ alien 16 }
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
} union type-numbers set

77
core/bootstrap/primitives.factor
View File

@ -3,8 +3,8 @@
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
tuples.private kernel.private vocabs vocabs.loader source-files
definitions slots.deprecated classes.union compiler.units
bootstrap.image.private io.files ;
IN: bootstrap.primitives
@ -33,7 +33,6 @@ H{ } clone changed-words set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
num-types get f <array> builtins set
init-caches
! Vocabulary for slot accessors
@ -47,6 +46,9 @@ call
call
call
! After we execute bootstrap/layouts
num-types get f <array> builtins set
! Create some empty vocabs where the below primitives and
! classes will go
{
@ -141,8 +143,6 @@ call
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"tuple" "kernel" create { } define-builtin
"ratio" "math" create {
{
{ "integer" "math" }
@ -178,8 +178,6 @@ call
"f" "syntax" lookup { } define-builtin
! do not word...
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
@ -293,6 +291,48 @@ define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "tuples.private" create {
{
{ "fixnum" "math" }
"hashcode"
{ "layout-hashcode" "tuples.private" }
f
}
{
{ "word" "words" }
"class"
{ "layout-class" "tuples.private" }
f
}
{
{ "fixnum" "math" }
"size"
{ "layout-size" "tuples.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
{ "layout-superclasses" "tuples.private" }
f
}
{
{ "fixnum" "math" }
"echelon"
{ "layout-echelon" "tuples.private" }
f
}
} define-builtin
"tuple" "kernel" create {
{
{ "tuple-layout" "tuples.private" }
"layout"
{ "tuple-layout" "tuples.private" }
f
}
} define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
"f" "syntax" lookup builtins get remove [ ] subset f union-class
@ -318,7 +358,9 @@ builtins get num-tags get tail f union-class define-class
"null" "kernel" create { } f union-class define-class
! Create special tombstone values
"tombstone" "hashtables.private" create { } define-tuple-class
"tombstone" "hashtables.private" create
"tuple" "kernel" lookup
{ } define-tuple-class
"((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup f
@ -330,6 +372,7 @@ builtins get num-tags get tail f union-class define-class
! Some tuple classes
"hashtable" "hashtables" create
"tuple" "kernel" lookup
{
{
{ "array-capacity" "sequences.private" }
@ -350,6 +393,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"sbuf" "sbufs" create
"tuple" "kernel" lookup
{
{
{ "string" "strings" }
@ -365,6 +409,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"vector" "vectors" create
"tuple" "kernel" lookup
{
{
{ "array" "arrays" }
@ -380,6 +425,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"byte-vector" "byte-vectors" create
"tuple" "kernel" lookup
{
{
{ "byte-array" "byte-arrays" }
@ -395,6 +441,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"bit-vector" "bit-vectors" create
"tuple" "kernel" lookup
{
{
{ "bit-array" "bit-arrays" }
@ -410,6 +457,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"float-vector" "float-vectors" create
"tuple" "kernel" lookup
{
{
{ "float-array" "float-arrays" }
@ -425,6 +473,7 @@ builtins get num-tags get tail f union-class define-class
} define-tuple-class
"curry" "kernel" create
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
@ -439,7 +488,12 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"curry" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
"compose" "kernel" create
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
@ -454,6 +508,10 @@ builtins get num-tags get tail f union-class define-class
}
} define-tuple-class
"compose" "kernel" lookup
dup f "inline" set-word-prop
dup tuple-layout [ <tuple-boa> ] curry define
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
@ -628,11 +686,10 @@ builtins get num-tags get tail f union-class define-class
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "<string>" "strings" }
{ "(>tuple)" "tuples.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "tuples.private" }
{ "tuple>array" "tuples" }
{ "<tuple-layout>" "tuples.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }

6
core/classes/algebra/algebra-docs.factor
View File

@ -39,15 +39,15 @@ HELP: sort-classes
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: class-or
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $values { "first" class } { "second" class } { "class" class } }
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $values { "first" class } { "second" class } { "class" class } }
{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: classes-intersect?
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
{ $values { "first" class } { "second" class } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
HELP: min-class

2
core/classes/algebra/algebra-tests.factor
View File

@ -51,7 +51,7 @@ UNION: both first-one union-class ;
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
PREDICATE: no-docs < word "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;

2
core/classes/classes-tests.factor
View File

@ -28,7 +28,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ f ] [ union-1 number class< ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test

15
core/classes/classes.factor
View File

@ -25,15 +25,15 @@ SYMBOL: class-or-cache
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
SYMBOL: update-map
SYMBOL: builtins
PREDICATE: class builtin-class
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
PREDICATE: class tuple-class
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
@ -47,7 +47,7 @@ PREDICATE: class tuple-class
: predicate-effect 1 { "?" } <effect> ;
PREDICATE: word predicate "predicating" word-prop >boolean ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
@ -118,10 +118,3 @@ GENERIC: update-methods ( assoc -- )
GENERIC: class ( object -- class ) inline
M: object class type type>class ;
<PRIVATE
: class-of-tuple ( obj -- class )
2 slot { word } declare ; inline
PRIVATE>

2
core/classes/mixin/mixin.factor
View File

@ -4,7 +4,7 @@ USING: classes classes.union words kernel sequences
definitions combinators arrays ;
IN: classes.mixin
PREDICATE: union-class mixin-class "mixin" word-prop ;
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
{ "metaclass" "members" "mixin" } reset-props ;

2
core/classes/predicate/predicate-docs.factor
View File

@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
ABOUT: "predicates"
HELP: define-predicate-class
{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;

8
core/classes/predicate/predicate.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words ;
IN: classes.predicate
PREDICATE: class predicate-class
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
: predicate-quot ( class -- quot )
@ -13,8 +13,8 @@ PREDICATE: class predicate-class
"predicate-definition" word-prop , [ drop f ] , \ if ,
] [ ] make ;
: define-predicate-class ( superclass class definition -- )
>r dup f roll predicate-class define-class r>
: define-predicate-class ( class superclass definition -- )
>r >r dup f r> predicate-class define-class r>
dupd "predicate-definition" set-word-prop
dup predicate-quot define-predicate ;

2
core/classes/union/union.factor
View File

@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays math quotations ;
IN: classes.union
PREDICATE: class union-class
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.

2
core/compiler/constants/constants.factor
View File

@ -15,7 +15,7 @@ IN: compiler.constants
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset bootstrap-cell object tag-number - ;
: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
: tuple-class-offset bootstrap-cell tuple tag-number - ;
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;

6
core/cpu/architecture/architecture.factor
View File

@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ;
M: object load-literal v>operand load-indirect ;
PREDICATE: integer small-slot cells small-enough? ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: integer small-tagged v>operand small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
PREDICATE: integer inline-array 32 < ;
PREDICATE: inline-array < integer 32 < ;
: if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and

2
core/cpu/arm/assembler/assembler.factor
View File

@ -27,7 +27,7 @@ SYMBOL: R15
{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
define-registers
PREDICATE: word register register >boolean ;
PREDICATE: register < word register >boolean ;
GENERIC: register ( register -- n )
M: word register "register" word-prop ;

12
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
\ <tuple> [
tuple "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
tuple "layout" get layout-size 2 + cells %allot
! Store layout
"layout" operand 12 LOAD32
12 11 cell STW
! Store class
"class" operand 11 2 cells STW
! Zero out the rest of the tuple
f v>operand 12 LI
"n" get 1- [ 12 11 rot 3 + cells STW ] each
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +input+ { { [ tuple-layout? ] "layout" } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic

2
core/cpu/x86/32/32.factor
View File

@ -8,7 +8,7 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
PREDICATE: x86-32-backend < x86-backend
x86-backend-cell 4 = ;
! We implement the FFI for Linux, OS X and Windows all at once.

2
core/cpu/x86/64/64.factor
View File

@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
PREDICATE: amd64-backend < x86-backend
x86-backend-cell 8 = ;
M: amd64-backend ds-reg R14 ;

24
core/cpu/x86/assembler/assembler.factor
View File

@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: word register "register" word-prop ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register register-8 "register-size" word-prop 8 = ;
PREDICATE: register register-16 "register-size" word-prop 16 = ;
PREDICATE: register register-32 "register-size" word-prop 32 = ;
PREDICATE: register register-64 "register-size" word-prop 64 = ;
PREDICATE: register register-128 "register-size" word-prop 128 = ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
PREDICATE: word callable register? not ;
PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ;

17
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics
} define-intrinsic
\ <tuple> [
tuple "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
! Store class
2 object@ "class" operand MOV
tuple "layout" get layout-size 2 + cells [
! Store layout
"layout" get "scratch" get load-literal
1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
"n" operand 1- [ 3 + object@ f v>operand MOV ] each
"layout" get layout-size [
2 + object@ f v>operand MOV
] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +scratch+ { { f "tuple" } } }
{ +input+ { { [ tuple-layout? ] "layout" } } }
{ +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } }
} define-intrinsic

2
core/debugger/debugger.factor
View File

@ -156,7 +156,7 @@ M: relative-overflow summary
: primitive-error.
"Unimplemented primitive" print drop ;
PREDICATE: array kernel-error ( obj -- ? )
PREDICATE: kernel-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }

2
core/generic/generic-tests.factor
View File

@ -44,7 +44,7 @@ M: object funny drop 0 ;
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
PREDICATE: funnies very-funny number? ;
PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;

7
core/generic/generic.factor
View File

@ -19,7 +19,8 @@ M: object perform-combination
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
PREDICATE: generic < word
"combination" word-prop >boolean ;
M: generic definition drop f ;
@ -30,7 +31,7 @@ M: generic definition drop f ;
: method ( class generic -- method/f )
"methods" word-prop at ;
PREDICATE: pair method-spec
PREDICATE: method-spec < pair
first2 generic? swap class? and ;
: order ( generic -- seq )
@ -55,7 +56,7 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
PREDICATE: word method-body
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body stack-effect

4
core/generic/math/math.factor
View File

@ -5,7 +5,7 @@ math namespaces sequences words quotations layouts combinators
sequences.private classes classes.algebra definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
PREDICATE: math-class < class
dup null bootstrap-word eq? [
drop f
] [
@ -79,7 +79,7 @@ M: math-combination perform-combination
] if nip
] math-vtable nip ;
PREDICATE: generic math-generic ( word -- ? )
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
M: math-generic definer drop \ MATH: f ;

6
core/generic/standard/standard.factor
View File

@ -174,13 +174,13 @@ M: hook-combination perform-combination
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
PREDICATE: generic standard-generic
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: standard-generic simple-generic
PREDICATE: simple-generic < standard-generic
"combination" word-prop standard-combination-# zero? ;
PREDICATE: generic hook-generic
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
GENERIC: dispatch# ( word -- n )

6
core/inference/dataflow/dataflow.factor
View File

@ -102,7 +102,7 @@ TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
PREDICATE: #label #loop #label-loop? ;
PREDICATE: #loop < #label #label-loop? ;
TUPLE: #entry ;
@ -309,9 +309,9 @@ SYMBOL: node-stack
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #tail-merge < #merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
PREDICATE: #tail-values < #values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ;

11
core/inference/known-words/known-words.factor
View File

@ -135,7 +135,7 @@ M: object infer-call
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
peek-d value-literal { tuple } <effect>
peek-d value-literal layout-size { tuple } <effect>
make-call-node
] "infer" set-word-prop
@ -565,14 +565,11 @@ set-primitive-effect
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
\ quotation-xt make-flushable
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
\ (>tuple) make-flushable
\ tuple>array { tuple } { array } <effect> set-primitive-effect
\ tuple>array make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable
\ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable

4
core/inference/transforms/transforms.factor
View File

@ -76,7 +76,7 @@ M: duplicated-slots-error summary
\ construct-boa [
dup +inlined+ depends-on
dup tuple-size [ <tuple-boa> ] 2curry
tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
\ construct-empty [
@ -84,7 +84,7 @@ M: duplicated-slots-error summary
peek-d value? [
pop-literal
dup +inlined+ depends-on
dup tuple-size [ <tuple> ] 2curry
tuple-layout [ <tuple> ] curry
swap infer-quot
] [
\ construct-empty 1 1 <effect> make-call-node

8
core/io/encodings/encodings-tests.factor
View File

@ -6,7 +6,7 @@ IN: io.streams.encodings.tests
resource-path ascii <file-reader> ;
[ { } ]
[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
[ "core/io/test/empty-file.txt" <resource-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
@ -16,21 +16,21 @@ unit-test
"This is a line."
"This is another line."
] [
"/core/io/test/windows-eol.txt" <resource-reader> lines-test
"core/io/test/windows-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
"core/io/test/mac-os-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"/core/io/test/unix-eol.txt" <resource-reader> lines-test
"core/io/test/unix-eol.txt" <resource-reader> lines-test
] unit-test
[

8
core/io/files/files-tests.factor
View File

@ -10,8 +10,6 @@ io.files.unique sequences strings accessors ;
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ "" ] [ "" file-name ] unit-test
[ "/" ] [ "/" file-name ] unit-test
[ "///" ] [ "///" file-name ] unit-test
[ ] [
{ "Hello world." }
@ -156,18 +154,12 @@ io.files.unique sequences strings accessors ;
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
[ "/lib" ] [ "/" "../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
[ "" ] [ "" "." append-path ] unit-test
[ "" ".." append-path ] must-fail
[ "/" ] [ "/" "./." append-path ] unit-test
[ "/" ] [ "/" "././" append-path ] unit-test
[ "/" ] [ "/" "../.." append-path ] unit-test
[ "/" ] [ "/" "../../" append-path ] unit-test
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test

8
core/io/io-tests.factor
View File

@ -4,7 +4,7 @@ io.encodings.binary ;
IN: io.tests
[ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file
"resource:core/io/test/no-trailing-eol.factor" run-file
"foo" "io.tests" lookup
] unit-test
@ -14,14 +14,14 @@ IN: io.tests
[
"This is a line.\rThis is another line.\r"
] [
"/core/io/test/mac-os-eol.txt" <resource-reader>
"core/io/test/mac-os-eol.txt" <resource-reader>
[ 500 read ] with-stream
] unit-test
[
255
] [
"/core/io/test/binary.txt" <resource-reader>
"core/io/test/binary.txt" <resource-reader>
[ read1 ] with-stream >fixnum
] unit-test
@ -36,7 +36,7 @@ IN: io.tests
}
] [
[
"/core/io/test/separator-test.txt" <resource-reader> [
"core/io/test/separator-test.txt" <resource-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,

39
core/kernel/kernel.factor
View File

@ -67,29 +67,7 @@ DEFER: if
[ >r tuck 2slip r> while ]
[ 2nip call ] if ; inline
! Quotation building
USE: tuples.private
: curry ( obj quot -- curry )
\ curry 4 <tuple-boa> ;
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: compose ( quot1 quot2 -- curry )
\ compose 4 <tuple-boa> ;
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
! Object protocol
GENERIC: delegate ( obj -- delegate )
M: object delegate drop f ;
@ -118,7 +96,6 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
@ -132,8 +109,22 @@ GENERIC: construct-boa ( ... class -- tuple )
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline
! Booleans
! Quotation building
USE: tuples.private
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
! Booleans
: not ( obj -- ? ) f eq? ; inline
: >boolean ( obj -- ? ) t f ? ; inline

7
core/optimizer/known-words/known-words.factor
View File

@ -11,12 +11,11 @@ classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
{ <tuple> <tuple-boa> } [
[
dup node-in-d dup length 2 - swap nth node-literal
dup class? [ drop tuple ] unless 1array f
dup node-in-d peek node-literal
dup tuple-layout? [ layout-class ] [ drop tuple ] if
1array f
] "output-classes" set-word-prop
] each

2
core/parser/parser-tests.factor
View File

@ -389,7 +389,7 @@ IN: parser.tests
] with-scope
[ ] [
"IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
[ t ] [

10
core/parser/parser.factor
View File

@ -214,7 +214,7 @@ SYMBOL: in
ERROR: unexpected want got ;
PREDICATE: unexpected unexpected-eof
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
: unexpected-eof ( word -- * ) f unexpected ;
@ -288,6 +288,14 @@ M: no-word summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> add* ]
} case ;
ERROR: staging-violation word ;
M: staging-violation summary

5
core/prettyprint/backend/backend.factor
View File

@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
tuples classes float-arrays float-vectors ;
tuples tuples.private classes float-arrays float-vectors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -202,3 +202,6 @@ M: wrapper pprint*
] [
pprint-object
] if ;
M: tuple-layout pprint*
"( tuple layout )" swap present-text ;

6
core/prettyprint/prettyprint-tests.factor
View File

@ -329,3 +329,9 @@ M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ \ f \ generic-see-test-with-f method see ] with-string-writer
] unit-test
PREDICATE: predicate-see-test < integer even? ;
[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
[ \ predicate-see-test see ] with-string-writer
] unit-test

6
core/prettyprint/prettyprint.factor
View File

@ -247,8 +247,9 @@ M: mixin-class see-class*
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
dup superclass pprint-word
dup pprint-word
"<" text
dup superclass pprint-word
<block
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
@ -256,6 +257,9 @@ M: predicate-class see-class*
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
"slot-names" word-prop [ text ] each
pprint-; block> ;

4
core/quotations/quotations.factor
View File

@ -7,9 +7,9 @@ IN: quotations
M: quotation call (call) ;
M: curry call dup 4 slot swap 5 slot call ;
M: curry call dup 3 slot swap 4 slot call ;
M: compose call dup 4 slot swap 5 slot slip call ;
M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;

2
core/sequences/sequences.factor
View File

@ -60,7 +60,7 @@ INSTANCE: immutable-sequence sequence
#! A bit of a pain; can't call cell-bits here
7 getenv 8 * 5 - 2^ 1- ; foldable
PREDICATE: fixnum array-capacity
PREDICATE: array-capacity < fixnum
0 max-array-capacity between? ;
: array-capacity ( array -- n )

4
core/slots/deprecated/deprecated.factor
View File

@ -8,7 +8,7 @@ IN: slots.deprecated
: reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
@ -30,7 +30,7 @@ PREDICATE: word slot-reader "reading" word-prop >boolean ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect

2
core/slots/slots-docs.factor
View File

@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors"
}
"In addition, two utility words are defined for each distinct slot name used in the system:"
{ $list
{ "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
}
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."

2
core/slots/slots.factor
View File

@ -46,7 +46,7 @@ C: <slot-spec> slot-spec
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;

10
core/syntax/syntax-docs.factor
View File

@ -543,8 +543,8 @@ HELP: INSTANCE:
{ $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
HELP: PREDICATE:
{ $syntax "PREDICATE: superclass class predicate... ;" }
{ $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
{ $syntax "PREDICATE: class < superclass predicate... ;" }
{ $values { "class" "a new class word to define" } { "superclass" "an existing class word" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description
"Defines a predicate class deriving from " { $snippet "superclass" } "."
$nl
@ -557,11 +557,9 @@ HELP: PREDICATE:
} ;
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class."
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }

13
core/syntax/syntax.factor
View File

@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators ;
combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -148,13 +148,14 @@ IN: bootstrap.syntax
] define-syntax
"PREDICATE:" [
scan-word
CREATE-CLASS
scan "<" assert=
scan-word
parse-definition define-predicate-class
] define-syntax
"TUPLE:" [
CREATE-CLASS ";" parse-tokens define-tuple-class
parse-tuple-definition define-tuple-class
] define-syntax
"C:" [
@ -164,9 +165,9 @@ IN: bootstrap.syntax
] define-syntax
"ERROR:" [
CREATE-CLASS dup ";" parse-tokens define-tuple-class
dup save-location
dup [ construct-boa throw ] curry define
parse-tuple-definition
pick save-location
define-error-class
] define-syntax
"FORGET:" [

24
core/tuples/tuples-docs.factor
View File

@ -153,10 +153,6 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: tuple-class-eq?
{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ;
HELP: permutation
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
@ -169,7 +165,7 @@ HELP: reshape-tuples
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
HELP: old-slots
HELP: removed-slots
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
@ -194,8 +190,8 @@ HELP: define-tuple-predicate
{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
$low-level-note ;
HELP: check-shape
{ $values { "class" class } { "newslots" "a sequence of strings" } }
HELP: redefine-tuple-class
{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } }
{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
$nl
"If the class is not a tuple class word, this word does nothing." }
@ -218,8 +214,8 @@ HELP: check-tuple
{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
HELP: define-tuple-class
{ $values { "class" word } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
@ -246,9 +242,13 @@ HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
HELP: <tuple> ( class n -- tuple )
{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
HELP: construct-empty
{ $values { "class" tuple-class } { "tuple" tuple } }

125
core/tuples/tuples-tests.factor
View File

@ -2,18 +2,19 @@ USING: definitions generic kernel kernel.private math
math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ;
strings compiler.units accessors classes.algebra calendar
prettyprint io.streams.string splitting ;
IN: tuples.tests
TUPLE: rect x y w h ;
: <rect> rect construct-boa ;
: move ( x rect -- )
[ rect-x + ] keep set-rect-x ;
: move ( x rect -- rect )
[ + ] change-x ;
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
GENERIC: delegation-test
M: object delegation-test drop 3 ;
@ -34,27 +35,46 @@ TUPLE: quuux-tuple-2 ;
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
C: <redefinition-test> redefinition-test
<redefinition-test> "redefinition-test" set
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: tuples.tests TUPLE: redefinition-test ;" eval
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
! Make sure we handle changing shapes!
TUPLE: point x y ;
C: <point> point
100 200 <point> "p" set
[ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly
"IN: tuples.tests TUPLE: point x y z ;" eval
[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test
[ 100 ] [ "p" get point-x ] unit-test
[ 200 ] [ "p" get point-y ] unit-test
[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
300 "p" get "set-point-z" "tuples.tests" lookup execute
"p" get 300 ">>z" "accessors" lookup execute drop
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"IN: tuples.tests TUPLE: point z y ;" eval
[ "p" get point-x ] must-fail
[ 200 ] [ "p" get point-y ] unit-test
[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
[ "p" get x>> ] must-fail
[ 200 ] [ "p" get y>> ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
TUPLE: predicate-test ;
@ -64,14 +84,14 @@ C: <predicate-test> predicate-test
[ t ] [ <predicate-test> predicate-test? ] unit-test
PREDICATE: tuple silly-pred
PREDICATE: silly-pred < tuple
class \ rect = ;
GENERIC: area
M: silly-pred area dup rect-w swap rect-h * ;
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
M: circle area circle-radius sq pi * ;
M: circle area radius>> sq pi * ;
[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
@ -88,7 +108,7 @@ TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } clone ] unit-test
! Compiler regression
[ t length ] [ no-method-object t eq? ] must-fail-with
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
@ -96,7 +116,7 @@ TUPLE: delegate-clone ;
TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } array-capacity
T{ size-test } tuple-size
size-test tuple-size =
] unit-test
@ -213,22 +233,69 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem construct-empty ;
: cons-test-2 \ erg's-reshape-problem construct-boa ;
: cons-test-3
{ set-erg's-reshape-problem-a }
\ erg's-reshape-problem construct ;
"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
[
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
[ "TUPLE: computer cpu ram ;" ] [
[ \ computer see ] with-string-writer string-lines second
] unit-test
TUPLE: laptop < computer battery ;
C: <laptop> laptop
[ t ] [ laptop tuple-class? ] unit-test
[ t ] [ laptop tuple class< ] unit-test
[ t ] [ laptop computer class< ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
[ t ] [ "laptop" get laptop? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second
] unit-test
TUPLE: server < computer rackmount? ;
C: <server> server
[ t ] [ server tuple-class? ] unit-test
[ t ] [ server tuple class< ] unit-test
[ t ] [ server computer class< ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 "1U" <server> "server" set ] unit-test
[ t ] [ "server" get server? ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
[ f ] [ server laptop class< ] unit-test
[ f ] [ laptop server class< ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ "TUPLE: server < computer rackmount? ;" ] [
[ \ server see ] with-string-writer string-lines second
] unit-test
[
"IN: tuples.tests TUPLE: bad-superclass < word ;" eval
] must-fail
! Hardcore unit tests
USE: threads
@ -236,14 +303,14 @@ USE: threads
[ ] [
[
\ thread { "xxx" } "slot-names" get append
\ thread tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
\ thread "slot-names" get
\ thread tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
@ -254,14 +321,14 @@ USE: vocabs
[ ] [
[
\ vocab { "xxx" } "slot-names" get append
\ vocab tuple { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab "slot-names" get
\ vocab tuple "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test

172
core/tuples/tuples.factor
View File

@ -1,31 +1,91 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.deprecated slots.private
classes classes.private slots.deprecated slots.private slots
compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
M: tuple delegate 2 slot ;
M: tuple set-delegate 3 set-slot ;
M: tuple set-delegate 2 set-slot ;
M: tuple class class-of-tuple ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
<PRIVATE
: tuple-size tuple-layout layout-size ; inline
PRIVATE>
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
layout-class add* ;
: >tuple ( sequence -- tuple )
dup first tuple-layout <tuple> [
>r 1 tail-slice dup length r>
[ tuple-size min ] keep
[ set-array-nth ] curry
2each
] keep ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity tuck number= [
-rot
over tuple-layout over tuple-layout eq? [
dup tuple-size -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
] [
3drop f
2drop f
] if ;
: tuple-class-eq? ( obj class -- ? )
over tuple? [ swap 2 slot eq? ] [ 2drop f ] if ; inline
M: tuple-class tuple-layout "layout" word-prop ;
: define-tuple-predicate ( class -- )
dup tuple-layout
[ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry
define-predicate ;
: delegate-slot-spec
T{ slot-spec f
object
"delegate"
2
delegate
set-delegate
} ;
: define-tuple-slots ( class slots -- )
dupd 3 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
2dup define-slots
define-accessors ;
: define-tuple-layout ( class -- )
dup
dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
"layout" set-word-prop ;
: removed-slots ( class newslots -- seq )
swap "slot-names" word-prop seq-diff ;
: forget-slots ( class newslots -- )
dupd removed-slots [
2dup
reader-word forget-method
writer-word forget-method
] with each ;
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
@ -33,7 +93,7 @@ M: tuple class class-of-tuple ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] with map
append (>tuple) ;
append >tuple ;
: reshape-tuples ( class newslots -- )
>r dup "slot-names" word-prop r> permutation
@ -43,63 +103,40 @@ M: tuple class class-of-tuple ;
become
] 2curry after-compilation ;
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
[ slot-spec-name swap member? not ] with subset ;
: tuple-class-unchanged ( class superclass slots -- ) 3drop ;
: forget-slots ( class newslots -- )
dupd old-slots [
2dup
slot-spec-reader 2array forget
slot-spec-writer 2array forget
] with each ;
: prepare-tuple-class ( class slots -- )
dupd define-tuple-slots
dup define-tuple-layout
define-tuple-predicate ;
: check-shape ( class newslots -- )
over tuple-class? [
over "slot-names" word-prop over = [
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
] unless
] when 2drop ;
: change-superclass "not supported" throw ;
GENERIC: tuple-size ( class -- size )
: redefine-tuple-class ( class superclass slots -- )
>r 2dup swap superclass eq?
[ drop ] [ dupd change-superclass ] if r>
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
prepare-tuple-class ;
M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
: define-new-tuple-class ( class superclass slots -- )
>r dupd f swap tuple-class define-class r>
prepare-tuple-class ;
PRIVATE>
: define-tuple-predicate ( class -- )
dup [ tuple-class-eq? ] curry define-predicate ;
: define-tuple-class ( class superclass slots -- )
{
{ [ pick tuple-class? not ] [ define-new-tuple-class ] }
{ [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
{ [ t ] [ redefine-tuple-class ] }
} cond ;
: delegate-slot-spec
T{ slot-spec f
object
"delegate"
3
delegate
set-delegate
} ;
: define-tuple-slots ( class slots -- )
dupd 4 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
2dup define-slots
define-accessors ;
ERROR: no-tuple-class class ;
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- )
2dup check-shape
over f tuple tuple-class define-class
over define-tuple-predicate
define-tuple-slots ;
: define-error-class ( class superclass slots -- )
pick >r define-tuple-class r>
dup [ construct-boa throw ] curry define ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -107,21 +144,14 @@ M: tuple clone
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
: (delegates) ( obj -- )
[ dup , delegate (delegates) ] when* ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
: >tuple ( seq -- tuple )
>vector dup first tuple-size over set-length
>array (>tuple) ;
M: tuple hashcode*
[
dup array-capacity -rot 0 -rot [
dup tuple-size -rot 0 -rot [
swapd array-nth hashcode* bitxor
] 2curry reduce
] recursive-hashcode ;
@ -131,7 +161,7 @@ M: tuple hashcode*
! Definition protocol
M: tuple-class reset-class
{
"metaclass" "superclass" "slot-names" "slots"
"metaclass" "superclass" "slot-names" "slots" "layout"
} reset-props ;
M: object get-slots ( obj slots -- ... )
@ -141,10 +171,10 @@ M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
M: object construct-empty ( class -- tuple )
dup tuple-size <tuple> ;
tuple-layout <tuple> ;
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
M: object construct-boa ( ... class -- tuple )
dup tuple-size <tuple-boa> ;
tuple-layout <tuple-boa> ;

6
core/words/words.factor
View File

@ -23,17 +23,17 @@ M: word definition word-def ;
ERROR: undefined ;
PREDICATE: word deferred ( obj -- ? )
PREDICATE: deferred < word ( obj -- ? )
word-def [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
PREDICATE: word symbol ( obj -- ? )
PREDICATE: symbol < word ( obj -- ? )
dup <wrapper> 1array swap word-def sequence= ;
M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
PREDICATE: word primitive ( obj -- ? )
PREDICATE: primitive < word ( obj -- ? )
word-def [ do-primitive ] tail? ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;

36
extra/builder/release/release.factor
View File

@ -1,6 +1,6 @@
USING: kernel system namespaces sequences splitting combinators
io.files io.launcher
io io.files io.launcher
bake combinators.cleave builder.common builder.util ;
IN: builder.release
@ -91,6 +91,39 @@ IN: builder.release
: remove-factor-app ( -- )
macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
: platform ( -- string ) { os cpu- } to-strings "-" join ;
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
platform
append-path ;
: upload ( -- )
{ "scp" archive-name remote-location } to-strings
[ "Error uploading binary to factorcode" print ]
run-or-bail ;
: maybe-upload ( -- )
upload-to-factorcode get
[ upload ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : release ( -- )
! "factor"
! [
! remove-factor-app
! remove-common-files
! ]
! with-directory
! make-archive
! archive-name releases move-file-into ;
: release ( -- )
"factor"
[
@ -99,6 +132,7 @@ IN: builder.release
]
with-directory
make-archive
maybe-upload
archive-name releases move-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

33
extra/combinators/lib/lib.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
! Eduardo Cavazos, Daniel Ehrenberg.
! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
! Doug Coleman, Eduardo Cavazos,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators namespaces quotations hashtables
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros bake combinators.cleave
continuations ;
@ -34,9 +35,8 @@ MACRO: nwith ( quot n -- )
MACRO: napply ( n -- )
2 [a,b]
[ [ ] [ 1- ] bi
[ , ntuck , nslip ]
bake ]
[ [ 1- ] [ ] bi
'[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
: 3apply ( obj obj obj quot -- ) 3 napply ; inline
@ -88,26 +88,21 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: preserving ( predicate -- quot )
dup infer effect-in
dup 1+
'[ , , nkeep , nrot ] ;
MACRO: ifte ( quot quot quot -- )
pick infer effect-in
dup 1+ swap
[ >r >r , nkeep , nrot r> r> if ]
bake ;
'[ , preserving , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: preserving ( predicate -- quot )
dup infer effect-in
dup 1+ spin
[ , , nkeep , nrot ]
bake ;
MACRO: switch ( quot -- )
[ [ preserving ] [ ] bi* ] assoc-map
[ , cond ]
bake ;
[ [ [ preserving ] curry ] dip ] assoc-map
[ cond ] curry ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/delegate/delegate.factor
View File

@ -10,7 +10,7 @@ IN: delegate
CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
PREDICATE: protocol < word "protocol-words" word-prop ;
GENERIC: group-words ( group -- words )

2
extra/help/markup/markup.factor
View File

@ -14,7 +14,7 @@ IN: help.markup
! Element types are words whose name begins with $.
PREDICATE: array simple-element
PREDICATE: simple-element < array
dup empty? [ drop t ] [ first word? not ] if ;
SYMBOL: last-element

2
extra/help/topics/topics.factor
View File

@ -16,7 +16,7 @@ M: link >link ;
M: vocab-spec >link ;
M: object >link link construct-boa ;
PREDICATE: link word-link link-name word? ;
PREDICATE: word-link < link link-name word? ;
M: link summary
[

6
extra/inverse/inverse.factor
View File

@ -54,9 +54,9 @@ M: no-inverse summary
: undo-literal ( object -- quot )
[ =/fail ] curry ;
PREDICATE: word normal-inverse "inverse" word-prop ;
PREDICATE: word math-inverse "math-inverse" word-prop ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
PREDICATE: normal-inverse < word "inverse" word-prop ;
PREDICATE: math-inverse < word "math-inverse" word-prop ;
PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: inline-word ( word -- )

6
extra/io/encodings/8-bit/8-bit.factor Normal file → Executable file
View File

@ -54,10 +54,8 @@ IN: io.encodings.8-bit
[ byte>ch ] [ ch>byte ] bi ;
: empty-tuple-class ( string -- class )
in get create
dup { f } "slots" set-word-prop
dup predicate-word drop
dup { } define-tuple-class ;
"io.encodings.8-bit" create
dup tuple { } define-tuple-class ;
: data-quot ( class word data -- quot )
>r [ word-name ] 2apply "/" swap 3append

4
extra/io/nonblocking/nonblocking.factor
View File

@ -22,8 +22,8 @@ M: port set-timeout set-port-timeout ;
SYMBOL: closed
PREDICATE: port input-port port-type input-port eq? ;
PREDICATE: port output-port port-type output-port eq? ;
PREDICATE: input-port < port port-type input-port eq? ;
PREDICATE: output-port < port port-type output-port eq? ;
GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- )

10
extra/io/unix/files/files-tests.factor
View File

@ -11,3 +11,13 @@ IN: io.unix.files.tests
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
[ t ] [ "///////" root-directory? ] unit-test
[ "/" ] [ "/" file-name ] unit-test
[ "///" ] [ "///" file-name ] unit-test
[ "/" ] [ "/" "../.." append-path ] unit-test
[ "/" ] [ "/" "../../" append-path ] unit-test
[ "/lib" ] [ "/" "../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test

3
extra/io/unix/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
io.unix.launcher.parser accessors ;
io.unix.launcher.parser accessors io.files ;
IN: io.unix.launcher
! Search unix first
@ -67,6 +67,7 @@ USE: unix
: spawn-process ( process -- * )
[
current-directory get cd
setup-priority
setup-redirection
dup pass-environment? [

1
extra/io/windows/files/files.factor
View File

@ -90,4 +90,3 @@ SYMBOLS: +read-only+ +hidden+ +system+
M: windows-nt-io file-info ( path -- info )
get-file-information-stat ;

5
extra/io/windows/launcher/launcher.factor
View File

@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
io.backend accessors concurrency.flags ;
io.backend accessors concurrency.flags io.files ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@ -27,7 +27,8 @@ TUPLE: CreateProcess-args
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles ;
TRUE >>bInheritHandles
current-directory get >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{

5
extra/io/windows/nt/files/files.factor
View File

@ -3,7 +3,7 @@ io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32
alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs
combinators.cleave ;
combinators.cleave namespaces ;
IN: io.windows.nt.files
M: windows-nt-io cwd
@ -63,11 +63,12 @@ ERROR: not-absolute-path ;
ERROR: nonstring-pathname ;
ERROR: empty-pathname ;
USE: tools.walker
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ nonstring-pathname ] unless
dup empty? [ empty-pathname ] when
{ { CHAR: / CHAR: \\ } } substitute
cwd swap windows-append-path
current-directory get swap windows-append-path
[ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;

36
extra/io/windows/nt/nt-tests.factor
View File

@ -1,36 +0,0 @@
USING: io.files kernel tools.test io.backend
io.windows.nt.files splitting ;
IN: io.windows.nt.tests
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
[ "c:" ] [ "c:\\" parent-directory ] unit-test
[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
[ ] [ "" resource-path cd ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
"C:\\builds\\factor\\12345\\"
"..\\log.txt" windows-append-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
"..\\.." windows-append-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
"..\\.." windows-append-path
] unit-test

14
extra/locals/locals.factor
View File

@ -29,23 +29,23 @@ TUPLE: wlet bindings body ;
C: <wlet> wlet
PREDICATE: word local "local?" word-prop ;
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word> dup t "local?" set-word-prop ;
PREDICATE: word local-word "local-word?" word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
PREDICATE: word local-reader "local-reader?" word-prop ;
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word> dup t "local-reader?" set-word-prop ;
PREDICATE: word local-writer "local-writer?" word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup word-name "!" append f <word>
@ -357,7 +357,7 @@ M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
PREDICATE: word lambda-word
PREDICATE: lambda-word < word
"lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
@ -373,7 +373,7 @@ M: lambda-word definition
M: lambda-word synopsis* lambda-word-synopsis ;
PREDICATE: macro lambda-macro
PREDICATE: lambda-macro < macro
"lambda" word-prop >boolean ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
@ -383,7 +383,7 @@ M: lambda-macro definition
M: lambda-macro synopsis* lambda-word-synopsis ;
PREDICATE: method-body lambda-method
PREDICATE: lambda-method < method-body
"lambda" word-prop >boolean ;
M: lambda-method definer drop \ M:: \ ; ;

2
extra/macros/macros.factor
View File

@ -17,7 +17,7 @@ IN: macros
: MACRO:
(:) define-macro ; parsing
PREDICATE: word macro "macro" word-prop >boolean ;
PREDICATE: macro < word "macro" word-prop >boolean ;
M: macro definer drop \ MACRO: \ ; ;

2
extra/memoize/memoize.factor
View File

@ -42,7 +42,7 @@ IN: memoize
: MEMO:
CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;
PREDICATE: memoized < word "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
M: memoized definition "memo-quot" word-prop ;

11
extra/multi-methods/multi-methods.factor
View File

@ -64,7 +64,8 @@ GENERIC: method-prologue ( combination -- quot )
TUPLE: method word def classes generic loc ;
PREDICATE: word method-body "multi-method" word-prop >boolean ;
PREDICATE: method-body < word
"multi-method" word-prop >boolean ;
M: method-body stack-effect
"multi-method" word-prop method-generic stack-effect ;
@ -209,13 +210,13 @@ M: hook-combination generic-prologue
USE: qualified
QUALIFIED: syntax
PREDICATE: word generic
PREDICATE: generic < word
"multi-combination" word-prop >boolean ;
PREDICATE: word standard-generic
PREDICATE: standard-generic < word
"multi-combination" word-prop standard-combination? ;
PREDICATE: word hook-generic
PREDICATE: hook-generic < word
"multi-combination" word-prop hook-combination? ;
syntax:M: standard-generic definer drop \ GENERIC: f ;
@ -233,7 +234,7 @@ syntax:M: hook-generic synopsis*
dup "multi-combination" word-prop
hook-combination-var pprint-word stack-effect. ;
PREDICATE: array method-spec
PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where

8
extra/opengl/shaders/shaders.factor
View File

@ -55,9 +55,9 @@ IN: opengl.shaders
: delete-gl-shader ( shader -- ) glDeleteShader ; inline
PREDICATE: integer gl-shader (gl-shader?) ;
PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
PREDICATE: gl-shader < integer (gl-shader?) ;
PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
! Programs
@ -126,7 +126,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
MACRO: with-gl-program ( uniforms quot -- )
(make-with-gl-program) ;
PREDICATE: integer gl-program (gl-program?) ;
PREDICATE: gl-program < integer (gl-program?) ;
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
>r <vertex-shader> check-gl-shader

10
extra/openssl/openssl-tests.factor
View File

@ -25,7 +25,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
[ ] [ ssl-v23 new-ctx ] unit-test
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
@ -33,10 +33,10 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key ] unit-test
[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
verify-load-locations ] unit-test
[ ] [ get-ctx 1 set-verify-depth ] unit-test
@ -45,7 +45,7 @@ verify-load-locations ] unit-test
! Load Diffie-Hellman parameters
! =========================================================
[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
[ ] [ get-bio f f f read-pem-dh-params ] unit-test
@ -129,7 +129,7 @@ verify-load-locations ] unit-test
! Dump errors to file
! =========================================================
[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test

9
extra/random/random.factor
View File

@ -4,6 +4,8 @@ USING: alien.c-types kernel math namespaces sequences
io.backend ;
IN: random
SYMBOL: random-generator
HOOK: os-crypto-random-bytes io-backend ( n -- byte-array )
HOOK: os-random-bytes io-backend ( n -- byte-array )
HOOK: os-crypto-random-32 io-backend ( -- r )
@ -11,16 +13,15 @@ HOOK: os-random-32 io-backend ( -- r )
GENERIC: seed-random ( tuple seed -- )
GENERIC: random-32 ( tuple -- r )
GENERIC: random-bytes* ( tuple n -- bytes )
: (random-bytes) ( tuple n -- byte-array )
M: object random-bytes* ( tuple n -- byte-array )
[ drop random-32 ] with map >c-uint-array ;
SYMBOL: random-generator
: random-bytes ( n -- r )
[
4 /mod zero? [ 1+ ] unless
random-generator get swap (random-bytes)
random-generator get swap random-bytes*
] keep head ;
: random ( seq -- elt )

29
extra/random/windows/cryptographic/cryptographic.factor Normal file
View File

@ -0,0 +1,29 @@
USING: accessors alien.c-types byte-arrays continuations
kernel random windows windows.advapi32 ;
IN: random.windows.cryptographic
TUPLE: windows-crypto-context handle ;
C: <windows-crypto-context> windows-crypto-context
M: windows-crypto-context dispose ( tuple -- )
handle>> 0 CryptReleaseContext win32-error=0/f ;
TUPLE: windows-cryptographic-rng context ;
C: <windows-cryptographic-rng> windows-cryptographic-rng
M: windows-cryptographic-rng dispose ( tuple -- )
context>> dispose ;
M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes )
>r context>> r> dup <byte-array>
[ CryptGenRandom win32-error=0/f ] keep ;
: acquire-aes-context ( -- bytes )
"HCRYPTPROV" <c-object>
dup f f PROV_RSA_AES CRYPT_NEWKEYSET
CryptAcquireContextW win32-error=0/f *void*
<windows-crypto-context> ;

5
extra/singleton/singleton.factor
View File

@ -5,8 +5,9 @@ sequences words ;
IN: singleton
: define-singleton ( token -- )
\ word swap create-class-in
dup [ eq? ] curry define-predicate-class ;
create-class-in
\ word
over [ eq? ] curry define-predicate-class ;
: SINGLETON:
scan define-singleton ; parsing

1
extra/tools/deploy/shaker/shaker.factor
View File

@ -155,7 +155,6 @@ IN: tools.deploy.shaker
layouts:tag-numbers
layouts:type-numbers
lexer-factory
lexer-factory
listener:listener-hook
root-cache
vocab-roots

2
extra/ui/commands/commands.factor
View File

@ -9,7 +9,7 @@ SYMBOL: +nullary+
SYMBOL: +listener+
SYMBOL: +description+
PREDICATE: word listener-command +listener+ word-prop ;
PREDICATE: listener-command < word +listener+ word-prop ;
GENERIC: invoke-command ( target command -- )

2
extra/ui/operations/operations.factor Normal file → Executable file
View File

@ -19,7 +19,7 @@ TUPLE: operation predicate command translator hook listener? ;
set-operation-hook
} operation construct ;
PREDICATE: operation listener-operation
PREDICATE: listener-operation < operation
dup operation-command listener-command?
swap operation-listener? or ;

2
extra/unicode/syntax/syntax.factor
View File

@ -35,7 +35,7 @@ IN: unicode.syntax
] [ ] make ;
: define-category ( word categories -- )
[category] fixnum -rot define-predicate-class ;
[category] integer swap define-predicate-class ;
: CATEGORY:
CREATE ";" parse-tokens define-category ; parsing

1554
extra/windows/advapi32/advapi32.factor
View File

File diff suppressed because it is too large Load Diff

1
extra/windows/types/types.factor
View File

@ -113,6 +113,7 @@ TYPEDEF: HANDLE HSZ
TYPEDEF: HANDLE WINSTA ! MS docs say typedef HANDLE WINSTA ;
TYPEDEF: HANDLE HWINSTA ! typo??
TYPEDEF: HANDLE HWND
TYPEDEF: HANDLE HCRYPTPROV
TYPEDEF: WORD LANGID
TYPEDEF: DWORD LCID
TYPEDEF: DWORD LCTYPE

2
extra/xml-rpc/xml-rpc.factor Normal file → Executable file
View File

@ -17,7 +17,7 @@ M: integer item>xml
[ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ;
PREDICATE: object boolean { t f } member? ;
PREDICATE: boolean < object { t f } member? ;
M: boolean item>xml
"1" "0" ? "boolean" build-tag ;

4
extra/xml/data/data.factor Normal file → Executable file
View File

@ -139,5 +139,5 @@ M: xml like
: <contained-tag> ( name attrs -- tag )
f <tag> ;
PREDICATE: tag contained-tag tag-children not ;
PREDICATE: tag open-tag tag-children ;
PREDICATE: contained-tag < tag tag-children not ;
PREDICATE: open-tag < tag tag-children ;

10
vm/data_gc.c
View File

@ -156,10 +156,12 @@ CELL untagged_object_size(CELL pointer)
/* Size of the data area of an object pointed to by an untagged pointer */
CELL unaligned_object_size(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
case ARRAY_TYPE:
case TUPLE_TYPE:
case BIGNUM_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case BYTE_ARRAY_TYPE:
@ -173,6 +175,10 @@ CELL unaligned_object_size(CELL pointer)
float_array_capacity((F_FLOAT_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case QUOTATION_TYPE:
return sizeof(F_QUOTATION);
case WORD_TYPE:
@ -192,6 +198,8 @@ CELL unaligned_object_size(CELL pointer)
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
case TUPLE_LAYOUT_TYPE:
return sizeof(F_TUPLE_LAYOUT);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */

31
vm/debug.c
View File

@ -57,6 +57,35 @@ void print_array(F_ARRAY* array, CELL nesting)
printf("...");
}
void print_tuple(F_TUPLE* tuple, CELL nesting)
{
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
CELL length = to_fixnum(layout->size);
printf(" ");
print_nested_obj(layout->class,nesting);
CELL i;
bool trimmed;
if(length > 10)
{
trimmed = true;
length = 10;
}
else
trimmed = false;
for(i = 0; i < length; i++)
{
printf(" ");
print_nested_obj(tuple_nth(tuple,i),nesting);
}
if(trimmed)
printf("...");
}
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
if(nesting <= 0)
@ -83,7 +112,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
break;
case TUPLE_TYPE:
printf("T{");
print_array(untag_object(obj),nesting - 1);
print_tuple(untag_object(obj),nesting - 1);
printf(" }");
break;
case ARRAY_TYPE:

56
vm/image.c
View File

@ -216,25 +216,45 @@ void fixup_callstack_object(F_CALLSTACK *stack)
/* Initialize an object in a newly-loaded image */
void relocate_object(CELL relocating)
{
do_slots(relocating,data_fixup);
switch(untag_header(get(relocating)))
/* Tuple relocation is a bit trickier; we have to fix up the
fixup object before we can get the tuple size, so do_slots is
out of the question */
if(untag_header(get(relocating)) == TUPLE_TYPE)
{
case WORD_TYPE:
fixup_word((F_WORD *)relocating);
break;
case QUOTATION_TYPE:
fixup_quotation((F_QUOTATION *)relocating);
break;
case DLL_TYPE:
ffi_dlopen((F_DLL *)relocating);
break;
case ALIEN_TYPE:
fixup_alien((F_ALIEN *)relocating);
break;
case CALLSTACK_TYPE:
fixup_callstack_object((F_CALLSTACK *)relocating);
break;
data_fixup((CELL *)relocating + 1);
CELL scan = relocating + 2 * CELLS;
CELL size = untagged_object_size(relocating);
CELL end = relocating + size;
while(scan < end)
{
data_fixup((CELL *)scan);
scan += CELLS;
}
}
else
{
do_slots(relocating,data_fixup);
switch(untag_header(get(relocating)))
{
case WORD_TYPE:
fixup_word((F_WORD *)relocating);
break;
case QUOTATION_TYPE:
fixup_quotation((F_QUOTATION *)relocating);
break;
case DLL_TYPE:
ffi_dlopen((F_DLL *)relocating);
break;
case ALIEN_TYPE:
fixup_alien((F_ALIEN *)relocating);
break;
case CALLSTACK_TYPE:
fixup_callstack_object((F_CALLSTACK *)relocating);
break;
}
}
}

25
vm/layouts.h
View File

@ -58,8 +58,9 @@ typedef signed long long s64;
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define BYTE_ARRAY_TYPE 18
#define TUPLE_LAYOUT_TYPE 19
#define TYPE_COUNT 19
#define TYPE_COUNT 20
INLINE bool immediate_p(CELL obj)
{
@ -224,3 +225,25 @@ typedef struct
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
typedef struct
{
CELL header;
/* tagged fixnum */
CELL hashcode;
/* tagged */
CELL class;
/* tagged fixnum */
CELL size;
/* tagged array */
CELL superclasses;
/* tagged fixnum */
CELL echelon;
} F_TUPLE_LAYOUT;
typedef struct
{
CELL header;
/* tagged layout */
CELL layout;
} F_TUPLE;

3
vm/primitives.c
View File

@ -169,11 +169,10 @@ void *primitives[] = {
primitive_wrapper,
primitive_clone,
primitive_string,
primitive_to_tuple,
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
primitive_tuple_to_array,
primitive_tuple_layout,
primitive_profiling,
primitive_become,
primitive_sleep,

5
vm/run.c
View File

@ -320,8 +320,9 @@ DEFINE_PRIMITIVE(class_hash)
CELL tag = TAG(obj);
if(tag == TUPLE_TYPE)
{
F_WORD *class = untag_object(get(SLOT(obj,2)));
drepl(class->hashcode);
F_TUPLE *tuple = untag_object(obj);
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
drepl(layout->hashcode);
}
else if(tag == OBJECT_TYPE)
drepl(get(UNTAG(obj)));

66
vm/types.c
View File

@ -379,45 +379,61 @@ DEFINE_PRIMITIVE(resize_float_array)
dpush(tag_object(reallot_float_array(array,capacity)));
}
/* Tuple layouts */
DEFINE_PRIMITIVE(tuple_layout)
{
F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
layout->echelon = dpop();
layout->superclasses = dpop();
layout->size = dpop();
layout->class = dpop();
layout->hashcode = untag_word(layout->class)->hashcode;
dpush(tag_object(layout));
}
/* Tuples */
/* push a new tuple on the stack */
F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
{
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
UNREGISTER_UNTAGGED(layout);
tuple->layout = tag_object(layout);
return tuple;
}
DEFINE_PRIMITIVE(tuple)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
dpush(tag_tuple(array));
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = to_fixnum(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
for(i = size - 1; i >= 0; i--)
put(AREF(tuple,i),F);
dpush(tag_tuple(tuple));
}
/* push a new tuple on the stack, filling its slots from the stack */
DEFINE_PRIMITIVE(tuple_boa)
{
CELL size = unbox_array_size();
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
set_array_nth(array,0,dpop());
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = to_fixnum(layout->size);
CELL i;
for(i = size - 1; i >= 2; i--)
set_array_nth(array,i,dpop());
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_tuple(layout);
UNREGISTER_UNTAGGED(layout);
dpush(tag_tuple(array));
}
/* set delegate slot */
put(AREF(tuple,0),F);
DEFINE_PRIMITIVE(tuple_to_array)
{
CELL object = dpeek();
type_check(TUPLE_TYPE,object);
object = RETAG(clone(object),OBJECT_TYPE);
set_slot(object,0,tag_header(ARRAY_TYPE));
drepl(object);
}
F_FIXNUM i;
for(i = size - 1; i >= 1; i--)
put(AREF(tuple,i),dpop());
DEFINE_PRIMITIVE(to_tuple)
{
CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
set_slot(object,0,tag_header(TUPLE_TYPE));
drepl(object);
dpush(tag_tuple(tuple));
}
/* Strings */

28
vm/types.h
View File

@ -96,11 +96,34 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
INLINE CELL tag_tuple(F_ARRAY *tuple)
INLINE CELL tag_tuple(F_TUPLE *tuple)
{
return RETAG(tuple,TUPLE_TYPE);
}
INLINE F_TUPLE *untag_tuple(CELL object)
{
type_check(TUPLE_TYPE,object);
return untag_object(object);
}
INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
{
CELL size = untag_fixnum_fast(layout->size);
return sizeof(F_TUPLE) + size * CELLS;
}
INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
{
return get(AREF(tuple,slot));
}
INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
{
put(AREF(tuple,slot),value);
write_barrier((CELL)tuple);
}
/* Prototypes */
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool to_boolean(CELL value);
@ -116,12 +139,11 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
DECLARE_PRIMITIVE(array);
DECLARE_PRIMITIVE(tuple);
DECLARE_PRIMITIVE(tuple_boa);
DECLARE_PRIMITIVE(tuple_layout);
DECLARE_PRIMITIVE(byte_array);
DECLARE_PRIMITIVE(bit_array);
DECLARE_PRIMITIVE(float_array);
DECLARE_PRIMITIVE(clone);
DECLARE_PRIMITIVE(tuple_to_array);
DECLARE_PRIMITIVE(to_tuple);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
DECLARE_PRIMITIVE(resize_array);