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

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

Conflicts:

	extra/semantic-db/hierarchy/hierarchy.factor
	extra/semantic-db/semantic-db.factor
db4
Alex Chapman 2008-03-25 23:01:07 +11:00
parent 18a09b54b1 c106a35b38
commit 42e5e07531
228 changed files with 8259 additions and 1682 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -18,4 +18,4 @@ factor
temp
logs
work
misc/wordsize
buildsupport/wordsize

8
Makefile
View File

@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS)
default: misc/wordsize
$(MAKE) `./misc/target`
default: build-support/wordsize
$(MAKE) `./build-support/target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
@ -162,8 +162,8 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
misc/wordsize: misc/wordsize.c
gcc misc/wordsize.c -o misc/wordsize
build-support/wordsize: build-support/wordsize.c
gcc build-support/wordsize.c -o build-support/wordsize
clean:
rm -f vm/*.o

168
build-support/grovel.c Normal file
View File

@ -0,0 +1,168 @@
#include <stdio.h>
#if defined(__FreeBSD__)
#define BSD
#define FREEBSD
#define UNIX
#endif
#if defined(__NetBSD__)
#define BSD
#define NETBSD
#define UNIX
#endif
#if defined(__OpenBSD__)
#define BSD
#define OPENBSD
#define UNIX
#endif
#if defined(__APPLE__)
#define BSD
#define MACOSX
#define UNIX
#endif
#if defined(linux)
#define LINUX
#define UNIX
#endif
#if defined(__amd64__) || defined(__x86_64__)
#define BIT64
#else
#define BIT32
#endif
#if defined(UNIX)
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/socket.h>
#include <sys/errno.h>
#include <sys/mman.h>
#include <fcntl.h>
#include <unistd.h>
#endif
#define BL printf(" ");
#define QUOT printf("\"");
#define NL printf("\n");
#define LB printf("{"); BL
#define RB BL printf("}");
#define SEMI printf(";");
#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL
#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB
#define grovel2(t,n) grovel2impl(t,n) NL
#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL
#define header(os) printf("vvv %s vvv", (os)); NL
#define footer(os) printf("^^^ %s ^^^", (os)); NL
#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
#define struct(n) printf("C-STRUCT: %s\n", (n));
#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL
void openbsd_types()
{
header2("openbsd", "types");
grovel(dev_t);
grovel(gid_t);
grovel(ino_t);
grovel(int32_t);
grovel(int64_t);
grovel(mode_t);
grovel(nlink_t);
grovel(off_t);
grovel(struct timespec);
grovel(uid_t);
footer2("openbsd", "types");
}
void openbsd_stat()
{
header2("openbsd", "stat");
struct("stat");
grovel2(dev_t, "st_dev");
grovel2(ino_t, "st_ino");
grovel2(mode_t, "st_mode");
grovel2(nlink_t, "st_nlink");
grovel2(uid_t, "st_uid");
grovel2(gid_t, "st_gid");
grovel2(dev_t, "st_rdev");
grovel2(int32_t, "st_lspare0");
grovel2(struct timespec, "st_atim");
grovel2(struct timespec, "st_mtim");
grovel2(struct timespec, "st_ctim");
grovel2(off_t, "st_size");
grovel2(int64_t, "st_blocks");
grovel2(u_int32_t, "st_blksize");
grovel2(u_int32_t, "st_flags");
grovel2(u_int32_t, "st_gen");
grovel2(int32_t, "st_lspare1");
grovel2(struct timespec, "st_birthtimespec");
grovel2(int64_t, "st_qspare1");
grovel2end(int64_t, "st_qspare2");
footer2("openbsd", "stat");
}
void unix_types()
{
grovel(dev_t);
grovel(gid_t);
grovel(ino_t);
grovel(int32_t);
grovel(int64_t);
grovel(mode_t);
grovel(nlink_t);
grovel(off_t);
grovel(struct timespec);
grovel(struct stat);
grovel(time_t);
grovel(uid_t);
}
void unix_constants()
{
constant(O_RDONLY);
constant(O_WRONLY);
constant(O_RDWR);
constant(O_APPEND);
constant(O_CREAT);
constant(O_TRUNC);
constant(O_EXCL);
constant(FD_SETSIZE);
constant(SOL_SOCKET);
constant(SO_REUSEADDR);
constant(SO_OOBINLINE);
constant(SO_SNDTIMEO);
constant(SO_RCVTIMEO);
constant(F_SETFL);
constant(O_NONBLOCK);
constant(EINTR);
constant(EAGAIN);
constant(EINPROGRESS);
constant(PROT_READ);
constant(PROT_WRITE);
constant(MAP_FILE);
constant(MAP_SHARED);
}
int main() {
#ifdef FREEBSD
grovel(blkcnt_t);
grovel(blksize_t);
grovel(fflags_t);
#endif
#ifdef OPENBSD
openbsd_stat();
openbsd_types();
#endif
#ifdef UNIX
unix_types();
unix_constants();
#endif
return 0;
}

38
build-support/target Executable file
View File

@ -0,0 +1,38 @@
#!/bin/sh
if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
then
echo freebsd-x86-32
elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ]
then
echo freebsd-x86-64
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
then
echo openbsd-x86-32
elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
then
echo openbsd-x86-64
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
then
echo netbsd-x86-32
elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ]
then
echo netbsd-x86-64
elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
elif [ `uname -s` = Darwin ]
then
echo macosx-x86-`./build-support/wordsize`
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
then
echo linux-x86-32
elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
then
echo linux-x86-64
elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
then
echo winnt-x86-`./build-support/wordsize`
else
echo help
fi

0
misc/wordsize.c → build-support/wordsize.c
View File

14
core/alien/alien.factor
View File

@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
TUPLE: alien-callback return parameters abi quot xt ;
TUPLE: alien-callback-error ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
\ alien-callback-error construct-empty throw ;
alien-callback-error ;
TUPLE: alien-indirect return parameters abi ;
TUPLE: alien-indirect-error ;
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
\ alien-indirect-error construct-empty throw ;
alien-indirect-error ;
TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke library function return parameters abi ;
TUPLE: alien-invoke-error library symbol ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
2over \ alien-invoke-error construct-boa throw ;
2over alien-invoke-error ;

4
core/alien/c-types/c-types.factor
View File

@ -26,9 +26,7 @@ global [
c-types [ H{ } assoc-like ] change
] bind
TUPLE: no-c-type name ;
: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
ERROR: no-c-type name ;
: (c-type) ( name -- type/f )
c-types get-global at dup [

54
core/alien/compiler/compiler.factor
View File

@ -6,14 +6,9 @@ inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts ;
compiler.errors continuations layouts accessors ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
GENERIC: alien-node-parameters ( node -- seq )
GENERIC: alien-node-return ( node -- ctype )
GENERIC: alien-node-abi ( node -- str )
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str )
] if ;
: alien-node-parameters* ( node -- seq )
dup alien-node-parameters
swap alien-node-return large-struct? [ "void*" add* ] when ;
dup parameters>>
swap return>> large-struct? [ "void*" add* ] when ;
: alien-node-return* ( node -- ctype )
alien-node-return dup large-struct? [ drop "void" ] when ;
return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str )
: alien-invoke-frame ( node -- n )
#! One cell is temporary storage, temp@
dup alien-node-return return-size
dup return>> return-size
swap alien-stack-frame +
cell + ;
@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: alien-invoke-stack ( node extra -- )
over alien-node-parameters length + dup reify-curries
over parameters>> length + dup reify-curries
over consume-values
dup alien-node-return "void" = 0 1 ?
dup return>> "void" = 0 1 ?
swap produce-values ;
: (make-prep-quot) ( parameters -- )
@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- )
] if ;
: make-prep-quot ( node -- quot )
alien-node-parameters
parameters>>
[ <reversed> (make-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
alien-node-parameters [
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
alien-node-return dup large-struct?
return>> dup large-struct?
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
: objects>registers ( node -- )
@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- )
] with-param-regs ;
: box-return* ( node -- )
alien-node-return [ ] [ box-return ] if-void ;
M: alien-invoke alien-node-parameters alien-invoke-parameters ;
M: alien-invoke alien-node-return alien-invoke-return ;
M: alien-invoke alien-node-abi
alien-invoke-library library
[ library-abi ] [ "cdecl" ] if* ;
return>> [ ] [ box-return ] if-void ;
M: alien-invoke-error summary
drop
@ -205,7 +193,7 @@ M: alien-invoke-error summary
: stdcall-mangle ( symbol node -- symbol )
"@"
swap alien-node-parameters parameter-sizes drop
swap parameters>> parameter-sizes drop
number>string 3append ;
TUPLE: no-such-library name ;
@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type
pop-literal nip over set-alien-invoke-return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
dup alien-invoke-library
library [ library-abi ] [ "cdecl" ] if*
over set-alien-invoke-abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
@ -274,10 +266,6 @@ M: alien-invoke generate-node
iterate-next
] with-stack-frame ;
M: alien-indirect alien-node-parameters alien-indirect-parameters ;
M: alien-indirect alien-node-return alien-indirect-return ;
M: alien-indirect alien-node-abi alien-indirect-abi ;
M: alien-indirect-error summary
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at
: register-callback ( word -- ) dup callbacks get set-at ;
M: alien-callback alien-node-parameters alien-callback-parameters ;
M: alien-callback alien-node-return alien-callback-return ;
M: alien-callback alien-node-abi alien-callback-abi ;
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
@ -373,7 +357,7 @@ TUPLE: callback-context ;
wait-to-return ; inline
: prepare-callback-return ( ctype -- quot )
alien-node-return {
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ t ] [ c-type c-type-prep ] }
@ -390,8 +374,8 @@ TUPLE: callback-context ;
: callback-unwind ( node -- n )
{
{ [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
{ [ dup alien-node-return large-struct? ] [ drop 4 ] }
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
{ [ t ] [ drop 0 ] }
} cond ;

61
core/alien/structs/structs-docs.factor
View File

@ -1,6 +1,65 @@
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays ;
alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces ;
! Deprecated code
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
[ { $instance } swap add ] 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 slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $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 slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $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 struct-type-fields ;

2
core/alien/structs/structs.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
alien.c-types cpu.architecture ;
slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )

4
core/alien/syntax/syntax.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
@ -9,7 +9,7 @@ IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
2 group dup keys swap values
2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )

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

@ -79,7 +79,7 @@ nl
"." write flush
{
malloc free memcpy
malloc calloc free memcpy
} compile
" done" print flush

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

@ -348,8 +348,10 @@ M: curry '
: emit-global ( -- )
[
{
dictionary source-files
typemap builtins class<map class-map update-map
dictionary source-files builtins
update-map class<-cache class-not-cache
classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
bootstrap-global set

21
core/bootstrap/primitives.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.primitives
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 classes.union compiler.units bootstrap.image.private
io.files ;
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -31,6 +31,13 @@ crossref off
H{ } clone dictionary set
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
"accessors" create-vocab drop
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
@ -90,11 +97,6 @@ call
"vectors.private"
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone update-map set
H{ } clone class<map set
H{ } clone class-map set
! Builtin classes
: builtin-predicate-quot ( class -- quot )
[
@ -127,9 +129,6 @@ H{ } clone class-map set
dup define-builtin-predicate
r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
! Forward definitions
"object" "kernel" create t "class" set-word-prop
"object" "kernel" create union-class "metaclass" set-word-prop

4
core/bootstrap/stage2.factor
View File

@ -12,7 +12,7 @@ SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when
".image" append ;
".image" append resource-path ;
: do-crossref ( -- )
"Cross-referencing..." print flush
@ -106,5 +106,5 @@ f error-continuation set-global
millis r> - dup bootstrap-time set-global
print-report
"output-image" get resource-path save-image-and-exit
"output-image" get save-image-and-exit
] if

55
core/classes/algebra/algebra-docs.factor Executable file
View File

@ -0,0 +1,55 @@
USING: help.markup help.syntax kernel classes ;
IN: classes.algebra
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection class-types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection class-types }
{ $subsection class-tags } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: class-types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of 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 } }
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" 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" } }
{ $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
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;

201
core/classes/algebra/algebra-tests.factor Executable file
View File

@ -0,0 +1,201 @@
IN: classes.algebra.tests
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects ;
: class= [ class< ] 2keep swap class< and ;
: class-and* >r class-and r> class= ;
: class-or* >r class-or r> class= ;
[ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test
[ t ] [ object fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum integer fixnum class-and* ] unit-test
[ t ] [ integer fixnum fixnum class-and* ] unit-test
[ t ] [ vector fixnum null class-and* ] unit-test
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: delegate-clone ;
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
TUPLE: c1 ;
UNION: x1 a1 b1 ;
UNION: y1 a1 c1 ;
UNION: z1 b1 c1 ;
[ f ] [ z1 x1 y1 class-and class< ] unit-test
[ t ] [ x1 y1 class-and a1 class< ] unit-test
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
] unit-test
[ t ] [
growable assoc class-and tuple class<
] unit-test
[ t ] [ object \ f \ f class-not class-or class< ] unit-test
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
[ f ] [ integer integer class-not classes-intersect? ] unit-test
[ t ] [ array number class-not class< ] unit-test
[ f ] [ bignum number class-not class< ] unit-test
[ vector ] [ vector class-not class-not ] unit-test
[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
[ f ] [ fixnum class-not integer class-and array class< ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ f ] [ number class-not array class< ] unit-test
[ f ] [ fixnum class-not array class< ] unit-test
[ t ] [ number class-not integer class-not class< ] unit-test
[ t ] [ vector array class-not class-and vector class= ] unit-test
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ t ] [ null class-not object class= ] unit-test
[ t ] [ object class-not null class= ] unit-test
[ f ] [ object class-not object class= ] unit-test
[ f ] [ null class-not null class= ] unit-test
! Test for hangs?
: random-class classes random ;
: random-op
{
class-and
class-or
class-not
} random ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
[ infer effect-in [ random-class ] times ] keep
call
drop
] unit-test
] times
: random-boolean
{ t f } random ;
: boolean>class
object null ? ;
: random-boolean-op
{
and
or
not
xor
} random ;
: class-xor [ class-or ] 2keep class-and class-not class-and ;
: boolean-op>class-op
{
{ and class-and }
{ or class-or }
{ not class-not }
{ xor class-xor }
} at ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
[ >r [ ] each r> call ] 2keep
>r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=
=
] unit-test
] times

233
core/classes/algebra/algebra.factor Executable file
View File

@ -0,0 +1,233 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
DEFER: (class<)
: class< ( first second -- ? )
class<-cache get [ (class<) ] 2cache ;
DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
DEFER: (class-and)
: class-and ( first second -- class )
class-and-cache get [ (class-and) ] 2cache ;
DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass< ( first second -- ? )
>r superclass r> class< ;
: left-union-class< ( first second -- ? )
>r members r> [ class< ] curry all? ;
: right-union-class< ( first second -- ? )
members [ class< ] with contains? ;
: left-anonymous-union< ( first second -- ? )
>r members>> r> [ class< ] curry all? ;
: right-anonymous-union< ( first second -- ? )
members>> [ class< ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class< ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class< ] with all? ;
: anonymous-complement< ( first second -- ? )
[ class>> ] 2apply swap class< ;
: (class<) ( first second -- -1/0/1 )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
{ [ t ] [ 2drop f ] }
} cond ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class< not ;
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: (classes-intersect?) ( first second -- ? )
{
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
{ [ dup members ] [ union-class-intersect? ] }
} cond ;
: left-union-and ( first second -- class )
>r members r> [ class-and ] curry map <anonymous-union> ;
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
: right-anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
{ [ over members ] [ left-union-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
{ [ t ] [ 2array <anonymous-intersection> ] }
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> add <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ;
: (class-or) ( first second -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
{ [ t ] [ 2array <anonymous-union> ] }
} cond ;
: (class-not) ( class -- complement )
{
{ [ dup anonymous-complement? ] [ class>> ] }
{ [ dup object eq? ] [ drop null ] }
{ [ dup null eq? ] [ drop object ] }
{ [ t ] [ <anonymous-complement> ] }
} cond ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
] assoc-map ;
: class-types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;

82
core/classes/classes-docs.factor
View File

@ -12,21 +12,6 @@ $nl
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection flatten-union-class } ;
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@ -93,15 +78,9 @@ HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: typemap
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: class<map
{ $var-description "Hashtable mapping each class to a set of classes which are contained in that class under the " { $link (class<) } " relation. The " { $link class< } " word uses this hashtable to avoid frequent expensive calls to " { $link (class<) } "." } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
@ -121,70 +100,13 @@ $low-level-note ;
HELP: superclass
{ $values { "class" class } { "super" class } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate and tuple classes." } ;
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ;
HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: flatten-union-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs the set of classes whose union is equal to " { $snippet "class" } ". Unions are expanded recursively so the output assoc does not contain any union classes. However, it may contain predicate classes whose superclasses are unions." } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class-empty?
{ $values { "class" "a class" } { "?" "a boolean" } }
{ $description "Tests if a class is a union class with no members." }
{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
HELP: (class<)
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Performs the calculation for " { $link class< } ". There is never any reason to call this word from user code since " { $link class< } " outputs identical values and caches results for better performance." } ;
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: lookup-union
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
{ class-and class-or lookup-union } related-words
HELP: class-or
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the smallest known class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the largest known class contained in both " { $snippet "class1" } " and " { $snippet "class2" } ". If the intersection is non-empty but no union class with those exact members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
HELP: classes-intersect?
{ $values { "class1" class } { "class2" 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
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;

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

@ -2,64 +2,10 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
classes.algebra vectors definitions source-files
compiler.units ;
IN: classes.tests
H{ } "s" set
[ ] [ 1 2 "s" get push-at ] unit-test
[ 1 ] [ 2 "s" get at first ] unit-test
[ ] [ 1 2 "s" get pop-at ] unit-test
[ t ] [ 2 "s" get at empty? ] unit-test
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ null ] [ slice reversed class-and ] unit-test
[ null ] [ general-t \ f class-and ] unit-test
[ object ] [ general-t \ f class-or ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ null ] [ vector virtual-sequence class-and ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
@ -76,16 +22,12 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class< ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
[ union-1 ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
[ object ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
@ -118,6 +60,9 @@ M: assoc-mixin collection-size assoc-size ;
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
@ -131,12 +76,8 @@ INSTANCE: integer mx1
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ mx1 ] [ array integer class-or ] unit-test
[ \ mx1 forget ] with-compilation-unit
[ f ] [ array integer class-or mx1 = ] unit-test
! Empty unions were causing problems
GENERIC: empty-union-test
@ -155,28 +96,12 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-2 class< ] unit-test
[ f ] [ fixnum quotation class-or redefine-bug-2 eq? ] unit-test
[ redefine-bug-2 ] [ bignum quotation class-or ] unit-test
! Another issue similar to the above
UNION: forget-class-bug-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[
\ forget-class-bug-1 forget
\ forget-class-bug-2 forget
] with-compilation-unit
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
USE: io.streams.string

255
core/classes/classes.factor
View File

@ -1,15 +1,32 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
IN: classes
USING: arrays definitions assocs kernel
kernel.private slots.private namespaces sequences strings words
vectors math quotations combinators sorting effects graphs ;
SYMBOL: class<-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
: init-caches ( -- )
H{ } clone class<-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
H{ } clone class-or-cache set ;
: reset-caches ( -- )
class<-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
SYMBOL: typemap
SYMBOL: class-map
SYMBOL: class<map
SYMBOL: update-map
SYMBOL: builtins
@ -19,7 +36,7 @@ PREDICATE: class builtin-class
PREDICATE: class tuple-class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) class<map get keys ;
: classes ( -- seq ) all-words [ class? ] subset ;
: type>class ( n -- class ) builtins get-global nth ;
@ -37,146 +54,12 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
#! Output f for non-classes to work with algebra code
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: members ( class -- seq ) "members" word-prop ;
: class-empty? ( class -- ? ) members dup [ empty? ] when ;
: (flatten-union-class) ( class -- )
dup members [
[ (flatten-union-class) ] each
] [
dup set
] ?if ;
: flatten-union-class ( class -- assoc )
[ (flatten-union-class) ] H{ } make-assoc ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: (flatten-builtin-class) ( class -- )
{
{ [ dup members ] [ members [ (flatten-builtin-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-builtin-class) ] }
{ [ t ] [ dup set ] }
} cond ;
: flatten-builtin-class ( class -- assoc )
[ (flatten-builtin-class) ] H{ } make-assoc ;
: types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class< ( class1 class2 -- ? ) swap class<map get at key? ;
<PRIVATE
DEFER: (class<)
: superclass< ( cls1 cls2 -- ? )
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
: union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys
[ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over class-empty? ] [ 2drop t ] }
{ [ 2dup superclass< ] [ 2drop t ] }
{ [ 2dup [ members not ] both? ] [ 2drop f ] }
{ [ t ] [ union-class< ] }
} cond ;
: lookup-union ( classes -- class )
typemap get at dup empty? [ drop object ] [ first ] if ;
: lookup-tuple-union ( classes -- class )
class-map get at dup empty? [ drop object ] [ first ] if ;
! : (class-or) ( class class -- class )
! [ flatten-builtin-class ] 2apply union lookup-union ;
!
! : (class-and) ( class class -- class )
! [ flatten-builtin-class ] 2apply intersect lookup-union ;
: class-or-fixup ( set set -- set )
union
tuple over key?
[ [ drop tuple-class? not ] assoc-subset ] when ;
: (class-or) ( class class -- class )
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
: (class-and) ( class class -- class )
2dup [ tuple swap class< ] either? [
[ flatten-builtin-class ] 2apply
intersect lookup-union
] [
[ flatten-class ] 2apply
intersect lookup-tuple-union
] if ;
: tuple-class-and ( class1 class2 -- class )
dupd eq? [ drop null ] unless ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE>
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: class-or ( class1 class2 -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ t ] [ (class-or) ] }
} cond ;
: class-and ( class1 class2 -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup [ tuple-class? ] both? ] [ tuple-class-and ] }
{ [ t ] [ (class-and) ] }
} cond ;
: classes-intersect? ( class1 class2 -- ? )
class-and class-empty? not ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
GENERIC: reset-class ( class -- )
@ -184,36 +67,9 @@ M: word reset-class drop ;
<PRIVATE
! class<map
: bigger-classes ( class -- seq )
classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep
class<map get set-at ;
: bigger-classes- ( class -- )
class<map get delete-at ;
: smaller-classes ( class -- seq )
classes swap [ (class<) ] curry subset ;
: smaller-classes+ ( class -- )
dup smaller-classes class<map get add-vertex ;
: smaller-classes- ( class -- )
dup smaller-classes class<map get remove-vertex ;
: class<map+ ( class -- )
H{ } clone over class<map get set-at
dup smaller-classes+ bigger-classes+ ;
: class<map- ( class -- )
dup smaller-classes- bigger-classes- ;
! update-map
: class-uses ( class -- seq )
[ dup members % superclass [ , ] when* ] { } make ;
dup members swap superclass [ add ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -224,47 +80,6 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
! typemap
: push-at ( value key assoc -- )
2dup at* [
2nip push
] [
drop >r >r 1vector r> r> set-at
] if ;
: typemap+ ( class -- )
dup flatten-builtin-class typemap get push-at ;
: pop-at ( value key assoc -- )
at* [ delete ] [ 2drop ] if ;
: typemap- ( class -- )
dup flatten-builtin-class typemap get pop-at ;
! class-map
: class-map+ ( class -- )
dup flatten-class class-map get push-at ;
: class-map- ( class -- )
dup flatten-class class-map get pop-at ;
! Class definition
: cache-class ( class -- )
dup typemap+ dup class-map+ dup class<map+ update-map+ ;
: cache-classes ( assoc -- )
[ drop cache-class ] assoc-each ;
GENERIC: uncache-class ( class -- )
M: class uncache-class
dup update-map- dup class<map- dup class-map- typemap- ;
M: word uncache-class drop ;
: uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ;
PRIVATE>
: define-class-props ( members superclass metaclass -- assoc )
@ -293,14 +108,12 @@ GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after.
reset-caches
define-class-props
over class? >r
over class-usages [
uncache-classes
over update-map-
dupd (define-class)
] keep cache-classes r>
[ class-usages dup update-predicates update-methods ]
[ drop ] if ;
dup update-map+
class-usages dup update-predicates update-methods ;
GENERIC: class ( object -- class ) inline

8
core/combinators/combinators.factor
View File

@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting ;
TUPLE: no-cond ;
: no-cond ( -- * ) \ no-cond construct-empty throw ;
ERROR: no-cond ;
: cond ( assoc -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
TUPLE: no-case ;
: no-case ( -- * ) \ no-case construct-empty throw ;
ERROR: no-case ;
: case ( obj assoc -- )
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip

3
core/compiler/compiler-docs.factor
View File

@ -8,7 +8,8 @@ $nl
"The main entry point to the optimizing compiler:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile } ;
{ $subsection decompile }
"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"

4
core/compiler/units/units-docs.factor
View File

@ -9,7 +9,9 @@ $nl
$nl
"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
{ $subsection with-compilation-unit }
"Words called to associate a definition with a source file location:"
"Compiling a set of words:"
{ $subsection compile }
"Words called to associate a definition with a compilation unit and a source file location:"
{ $subsection remember-definition }
{ $subsection remember-class }
"Forward reference checking (see " { $link "definition-checking" } "):"

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

@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
compiler compiler.units io vocabs.loader ;
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- )
#! have to fix ESP.
{
{
[ dup alien-node-abi "stdcall" = ]
[ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
[ dup alien-node-return large-struct? ]
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
} {
[ t ] [ drop ]

30
core/debugger/debugger.factor
View File

@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
kernel.private libc ;
kernel.private libc io.encodings ;
IN: debugger
GENERIC: error. ( error -- )
@ -75,9 +75,7 @@ SYMBOL: error-hook
: try ( quot -- )
[ error-hook get call ] recover ;
TUPLE: assert got expect ;
: assert ( got expect -- * ) \ assert construct-boa throw ;
ERROR: assert got expect ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
@ -86,28 +84,22 @@ TUPLE: assert got expect ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ;
TUPLE: relative-underflow stack ;
: relative-underflow ( before after -- * )
trim-datastacks nip \ relative-underflow construct-boa throw ;
ERROR: relative-underflow stack ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
TUPLE: relative-overflow stack ;
ERROR: relative-overflow stack ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
: relative-overflow ( before after -- * )
trim-datastacks drop \ relative-overflow construct-boa throw ;
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
{ -1 [ relative-underflow ] }
{ -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] }
{ 1 [ relative-overflow ] }
{ 1 [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
@ -210,13 +202,13 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: check-closed summary
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for create-method" ;
M: check-tuple summary
M: no-tuple-class summary
drop "Invalid class for define-constructor" ;
M: no-cond summary
@ -254,7 +246,7 @@ M: no-compilation-unit error.
M: no-vocab summary
drop "Vocabulary does not exist" ;
M: check-ptr summary
M: bad-ptr summary
drop "Memory allocation failed" ;
M: double-free summary
@ -282,6 +274,10 @@ M: thread error-in-thread ( error thread -- )
] bind
] if ;
M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
<PRIVATE
: init-debugger ( -- )

5
core/definitions/definitions.factor
View File

@ -3,10 +3,7 @@
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
TUPLE: no-compilation-unit definition ;
: no-compilation-unit ( definition -- * )
\ no-compilation-unit construct-boa throw ;
ERROR: no-compilation-unit definition ;
GENERIC: where ( defspec -- loc )

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

@ -85,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
@ -93,20 +93,20 @@ HELP: dlist-find
} ;
HELP: dlist-contains?
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if*
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
{ $values { "quot" quotation } { "dlist" { $link dlist } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

26
core/dlists/dlists-tests.factor
View File

@ -43,20 +43,20 @@ IN: dlists.tests
dlist-front dlist-node-next dlist-node-next
] unit-test
[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

126
core/dlists/dlists.factor
View File

@ -1,71 +1,67 @@
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences ;
USING: combinators kernel math sequences accessors ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist construct-empty
0 over set-dlist-length ;
0 >>length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ;
: dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE
TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node
: inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline
[ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
[ dlist-length 1- ] keep set-dlist-length ; inline
[ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-prev ] [ drop ] if* ;
[ (>>prev) ] [ drop ] if* ;
: set-next-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-next ] [ drop ] if* ;
[ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- )
dup dlist-node-next set-prev-when ;
dup next>> set-prev-when ;
: normalize-front ( dlist -- )
dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- )
dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- )
dup dlist-back
[ drop ] [ dup dlist-front swap set-dlist-back ] if ;
dup back>> [ dup front>> >>back ] unless drop ;
: set-front-to-back ( dlist -- )
dup dlist-front
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
dup front>> [ dup back>> >>front ] unless drop ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ; inline
: (dlist-find-node) ( dlist-node quot -- node/f ? )
over [
[ >r obj>> r> call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
] [ 2drop f f ] if ; inline
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ; inline
: dlist-each-node ( dlist quot -- )
[ t ] compose dlist-find-node 2drop ; inline
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front* ( obj dlist -- dlist-node )
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
@ -76,9 +72,9 @@ PRIVATE>
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] 2keep
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
@ -89,70 +85,75 @@ PRIVATE>
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
front>> obj>> ;
: pop-front ( dlist -- obj )
dup dlist-front [
dup dlist-node-next
f rot set-dlist-node-next
dup front>> [
dup next>>
f rot (>>next)
f over set-prev-when
swap set-dlist-front
] 2keep dlist-node-obj
swap (>>front)
] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
dlist-back dlist-node-obj ;
back>> obj>> ;
: pop-back ( dlist -- obj )
dup dlist-back [
dup dlist-node-prev
f rot set-dlist-node-prev
dup back>> [
dup prev>>
f rot (>>prev)
f over set-next-when
swap set-dlist-back
] 2keep dlist-node-obj
swap (>>back)
] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
: dlist-find ( dlist quot -- obj/f ? )
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( quot dlist -- ? )
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ;
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- )
{
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
: delete-node-if* ( quot dlist -- obj/f ? )
tuck dlist-find-node [
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
: delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [
dup [
[ delete-node ] keep obj>> t
] [
2drop f f
] if
] [
2drop f f
] if ; inline
: delete-node-if ( quot dlist -- obj/f )
: delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node-if ;
swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
f over set-dlist-front
f over set-dlist-back
0 swap set-dlist-length ;
f >>front
f >>back
0 >>length
drop ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline
[ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
@ -160,4 +161,3 @@ PRIVATE>
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

21
core/generator/registers/registers.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private combinators
cpu.architecture generator.fixup hashtables kernel layouts math
namespaces quotations sequences system vectors words effects
alien byte-arrays bit-arrays float-arrays ;
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays ;
IN: generator.registers
SYMBOL: +input+
@ -581,13 +581,14 @@ M: loc lazy-store
2drop t
] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
dup hi-tag class< [
drop object tag-number
] [
flatten-builtin-class keys
dup length 1 = [ first tag-number ] [ drop f ] if
] if ;
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax words classes definitions kernel
alien sequences math quotations generic.standard generic.math
combinators ;
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"
@ -126,7 +126,7 @@ HELP: method
{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
HELP: methods
@ -143,7 +143,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $values { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;

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

@ -1,8 +1,8 @@
USING: alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting
compiler.units ;
quotations classes classes.algebra continuations layouts
classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )

4
core/generic/generic.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
quotations arrays vocabs effects ;
classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
@ -138,7 +138,7 @@ M: method-body forget*
M: class forget* ( class -- )
dup forget-methods
dup uncache-class
dup update-map-
forget-word ;
M: assoc update-methods ( assoc -- )

2
core/generic/math/math-docs.factor Normal file → Executable file
View File

@ -15,7 +15,7 @@ HELP: no-math-method
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

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

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes definitions ;
sequences.private classes classes.algebra definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
@ -16,8 +16,8 @@ PREDICATE: class math-class ( object -- ? )
: math-precedence ( class -- n )
{
{ [ dup class-empty? ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ types last/first ] }
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
{ [ t ] [ drop { 100 100 } ] }
} cond ;
@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
dup empty? [ [ dip ] curry [ ] like ] unless
r> append ;
TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ;
ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;

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

@ -3,7 +3,7 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.private ;
classes classes.algebra classes.private ;
IN: generic.standard
TUPLE: standard-combination # ;
@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
TUPLE: no-method object generic ;
: no-method ( object generic -- * )
\ no-method construct-boa throw ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;

11
core/inference/class/class.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes inference.dataflow inference.backend
combinators ;
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
IN: inference.class
! Class inference
@ -88,8 +88,11 @@ M: interval-constraint apply-constraint
swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- )
>r "interval" word-prop dup
[ r> set-value-interval* ] [ r> 2drop ] if ;
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
value-classes get at object or ;

4
core/inference/inference-tests.factor
View File

@ -514,10 +514,10 @@ DEFER: an-inline-word
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
TUPLE: custom-error ;
ERROR: custom-error ;
[ T{ effect f 0 0 t } ] [
[ custom-error construct-boa throw ] infer
[ custom-error ] infer
] unit-test
: funny-throw throw ; inline

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

@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
\ get-slots [ [get-slots] ] 1 define-transform
TUPLE: duplicated-slots-error names ;
ERROR: duplicated-slots-error names ;
M: duplicated-slots-error summary
drop "Calling set-slots with duplicate slot setters" ;
: duplicated-slots-error ( names -- * )
\ duplicated-slots-error construct-boa throw ;
\ set-slots [
dup all-unique?
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if

21
core/io/encodings/encodings-docs.factor
View File

@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream"
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
HELP: <encoder> ( stream encoding -- newstream )
HELP: <encoder>
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <decoder> ( stream encoding -- newstream )
HELP: <decoder>
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
@ -37,10 +37,11 @@ HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
$nl { $vocab-link "io.encodings.utf8" }
$nl { $vocab-link "io.encodings.ascii" }
$nl { $vocab-link "io.encodings.binary" }
$nl { $vocab-link "io.encodings.utf16" } ;
{ $vocab-subsection "io.encodings.utf8" }
{ $vocab-subsection "io.encodings.ascii" }
{ $vocab-subsection "io.encodings.8-bit" }
{ $vocab-subsection "io.encodings.binary" }
{ $vocab-subsection "io.encodings.utf16" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
@ -50,12 +51,12 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
{ $subsection <encoder> }
{ $subsection <decoder> } ;
HELP: decode-char ( stream encoding -- char/f )
HELP: decode-char
{ $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } }
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
HELP: encode-char ( char stream encoding -- )
HELP: encode-char
{ $values { "char" "a character" }
{ "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }

10
core/io/encodings/encodings.factor
View File

@ -12,23 +12,19 @@ GENERIC: decode-char ( stream encoding -- char/f )
GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream decoding -- newstream )
GENERIC: <decoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;
TUPLE: decoder stream code cr ;
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
ERROR: decode-error ;
GENERIC: <encoder> ( stream encoding -- newstream )
TUPLE: encoder stream code ;
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
ERROR: encode-error ;
! Decoding

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

@ -1,5 +1,6 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
USING: tools.test io.files io threads kernel continuations io.encodings.ascii
io.files.unique sequences strings accessors ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
@ -130,4 +131,16 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
[ 123 ] [
"core" ".test" [
[
ascii [
123 CHAR: a <repetition> >string write
] with-file-writer
] keep file-info size>>
] with-unique-file
] unit-test

7
core/io/files/files.factor
View File

@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: special-directory? ( name -- ? ) { "." ".." } member? ;
TUPLE: no-parent-directory path ;
: no-parent-directory ( path -- * )
\ no-parent-directory construct-boa throw ;
ERROR: no-parent-directory path ;
: parent-directory ( path -- parent )
right-trim-separators {
@ -193,7 +190,7 @@ DEFER: copy-tree-into
! Special paths
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: ?resource-path ( path -- newpath )

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

@ -1,5 +1,5 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces io.encodings.latin1
tools.test words namespaces io.encodings.8-bit
io.encodings.binary ;
IN: io.tests
@ -9,7 +9,7 @@ IN: io.tests
] unit-test
: <resource-reader> ( resource -- stream )
resource-path latin1 <file-reader> ;
resource-path iso-8859-1 <file-reader> ;
[
"This is a line.\rThis is another line.\r"
@ -28,15 +28,6 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
[ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
[
"/core/io/test/binary.txt" <resource-reader>
[ 0.2 read ] with-stream
] must-fail
[
{
{ "It seems " CHAR: J }
@ -58,3 +49,12 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
! [ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
! [
! "/core/io/test/binary.txt" <resource-reader>
! [ 0.2 read ] with-stream
! ] must-fail

5
core/io/streams/duplex/duplex.factor
View File

@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
TUPLE: check-closed ;
ERROR: stream-closed-twice ;
: check-closed ( stream -- )
duplex-stream-closed?
[ \ check-closed construct-boa throw ] when ;
duplex-stream-closed? [ stream-closed-twice ] when ;
: duplex-stream-in+ ( duplex -- stream )
dup check-closed duplex-stream-in ;

14
core/libc/libc.factor
View File

@ -23,20 +23,14 @@ SYMBOL: mallocs
PRIVATE>
TUPLE: check-ptr ;
ERROR: bad-ptr ;
: check-ptr ( c-ptr -- c-ptr )
[ \ check-ptr construct-boa throw ] unless* ;
[ bad-ptr ] unless* ;
TUPLE: double-free ;
ERROR: double-free ;
: double-free ( -- * )
\ double-free construct-empty throw ;
TUPLE: realloc-error ptr size ;
: realloc-error ( alien size -- * )
\ realloc-error construct-boa throw ;
ERROR: realloc-error ptr size ;
<PRIVATE

9
core/mirrors/mirrors-docs.factor
View File

@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ;
IN: mirrors
ARTICLE: "mirrors" "Mirrors"
"A reflective view of an object's slots and their values:"
"The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities."
$nl
"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
"A view of a sequence as an associative structure:"
"An enum provides such a view of a sequence:"
{ $subsection enum }
{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror } ;
{ $subsection make-mirror }
{ $see-also "slots" } ;
ABOUT: "mirrors"

4
core/optimizer/control/control.factor
View File

@ -3,8 +3,8 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard ;
IN: optimizer.control
! ! ! Rudimentary CFA

10
core/optimizer/inlining/inlining.factor
View File

@ -3,10 +3,10 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard
optimizer.specializers optimizer.def-use optimizer.pattern-match
generic.standard optimizer.control kernel.private ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -175,7 +175,7 @@ DEFER: (flat-length)
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
[ class-types length 1 = ] all?
] [
2drop f
] if ;

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

@ -7,8 +7,9 @@ sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
optimizer.inlining float-arrays sequences.private combinators ;
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
@ -89,10 +90,10 @@ optimizer.inlining float-arrays sequences.private combinators ;
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
node-class-first types length 1 number= ;
node-class-first class-types length 1 number= ;
: fold-known-type ( node -- node )
dup node-class-first types inline-literals ;
dup node-class-first class-types inline-literals ;
\ type [
{ [ dup known-type? ] [ fold-known-type ] }

7
core/optimizer/math/math.factor
View File

@ -5,9 +5,10 @@ USING: alien alien.accessors arrays generic hashtables kernel
assocs math math.private kernel.private sequences words parser
inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
optimizer.inlining generic.standard system ;
combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining
generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }

5
core/optimizer/optimizer-tests.factor
View File

@ -1,8 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ;
optimizer.backend classes classes.algebra inference.dataflow
tuples.private continuations growable optimizer.inlining
namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [

2
core/optimizer/pattern-match/pattern-match.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.pattern-match
USING: kernel sequences inference namespaces generic
combinators classes inference.dataflow ;
combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching
SYMBOL: @

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

@ -224,7 +224,7 @@ HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
HELP: change-column
HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;

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

@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting tuples compiler.units debugger vocabs.loader ;
sorting tuples compiler.units debugger vocabs vocabs.loader ;
IN: parser.tests
[
@ -461,3 +461,11 @@ must-fail-with
] times
[ ] [ "parser" reload ] unit-test
[ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test
[
"USE: this-better-not-exist" eval
] must-fail

27
core/parser/parser.factor
View File

@ -60,7 +60,7 @@ t parser-notes set-global
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ;
: change-column ( lexer quot -- )
: change-lexer-column ( lexer quot -- )
swap
[ dup lexer-column swap lexer-line-text rot call ] keep
set-lexer-column ; inline
@ -68,14 +68,14 @@ t parser-notes set-global
GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- )
[ t skip ] change-column ;
[ t skip ] change-lexer-column ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
] change-column ;
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
dup lexer-line swap lexer-text length <= ;
@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ;
TUPLE: bad-escape ;
: bad-escape ( -- * )
\ bad-escape construct-empty throw ;
ERROR: bad-escape ;
M: bad-escape summary drop "Bad escape code" ;
@ -156,7 +153,7 @@ name>char-hook global [
: parse-string ( -- str )
lexer get [
[ swap tail-slice (parse-string) ] "" make swap
] change-column ;
] change-lexer-column ;
TUPLE: parse-error file line col text ;
@ -215,10 +212,7 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
\ unexpected construct-boa throw ;
ERROR: unexpected want got ;
PREDICATE: unexpected unexpected-eof
unexpected-got not ;
@ -294,10 +288,7 @@ M: no-word summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
\ staging-violation construct-boa throw ;
ERROR: staging-violation word ;
M: staging-violation summary
drop
@ -352,9 +343,7 @@ SYMBOL: lexer-factory
] if
] if ;
TUPLE: bad-number ;
: bad-number ( -- * ) \ bad-number construct-boa throw ;
ERROR: bad-number ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;

12
core/sequences/sequences.factor
View File

@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
TUPLE: bounds-error index seq ;
: bounds-error ( n seq -- * )
\ bounds-error construct-boa throw ;
ERROR: bounds-error index seq ;
: bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline
MIXIN: immutable-sequence
TUPLE: immutable seq ;
: immutable ( seq -- * ) \ immutable construct-boa throw ;
ERROR: immutable seq ;
M: immutable-sequence set-nth immutable ;
@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
: collapse-slice ( m n slice -- m' n' seq )
dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
TUPLE: slice-error reason ;
: slice-error ( str -- * ) \ slice-error construct-boa throw ;
ERROR: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when

95
core/slots/deprecated/deprecated.factor Executable file
View File

@ -0,0 +1,95 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: 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> slot-spec-name 1array <effect> ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over slot-spec-reader
swap "declared-effect" set-word-prop
slot-spec-reader swap "reading" set-word-prop ;
: define-reader ( class spec -- )
dup slot-spec-reader [
[ set-reader-props ] 2keep
dup slot-spec-offset
over slot-spec-reader
rot slot-spec-type reader-quot
define-slot-word
] [
2drop
] if ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over slot-spec-writer
swap "declared-effect" set-word-prop
slot-spec-writer swap "writing" set-word-prop ;
: define-writer ( class spec -- )
dup slot-spec-writer [
[ set-writer-props ] 2keep
dup slot-spec-offset
swap slot-spec-writer
[ set-slot ]
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 word-vocabulary >r >r word-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 ;
: short-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: long-slot ( spec # -- spec )
>r [ dup array? [ first2 create ] when ] map first4 r>
-rot <slot-spec> ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map [
{
{ [ over not ] [ 2drop f ] }
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] subset nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;

144
core/slots/slots-docs.factor Normal file → Executable file
View File

@ -4,25 +4,86 @@ effects generic.standard tuples slots.private classes
strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
{ $list
{ "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
{ "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
}
"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 "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."
$nl
"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
{ $code
"<email>"
" \"Happy birthday\" >>subject"
" { \"bob@bigcorp.com\" } >>to"
" \"alice@bigcorp.com\" >>from"
"send-email"
}
"The following uses writers, and requires some stack shuffling:"
{ $code
"<email>"
" \"Happy birthday\" over (>>subject)"
" { \"bob@bigcorp.com\" } over (>>to)"
" \"alice@bigcorp.com\" over (>>from)"
"send-email"
}
"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
{ $code
"<email>"
" swap >>subject"
" swap >>to"
" \"alice@bigcorp.com\" >>from"
"send-email"
}
"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
{ $code
"<email>"
" tuck (>>subject)"
" tuck (>>to)"
" \"alice@bigcorp.com\" over (>>from)"
"send-email"
}
"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
{ $code
"find-manager"
" salary>> 0.75 * >>salary"
}
"The following version is preferred:"
{ $code
"find-manager"
" [ 0.75 * ] change-salary"
}
{ $see-also "slots" "mirrors" } ;
ARTICLE: "slots" "Slots"
"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
"A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
$nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
{ $subsection slot-spec-reader }
{ $subsection slot-spec-writer }
"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
{ $subsection slot-of-reader }
{ $subsection slot-of-writer }
"Reader and writer words form classes:"
{ $subsection slot-reader }
{ $subsection slot-writer }
"Slot readers and writers type check, then call unsafe primitives:"
{ $subsection slot }
{ $subsection set-slot } ;
"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
{ $subsection reader-word }
{ $subsection writer-word }
{ $subsection setter-word }
{ $subsection changer-word }
"Looking up a slot by name:"
{ $subsection slot-named }
"Defining slots dynamically:"
{ $subsection define-reader }
{ $subsection define-writer }
{ $subsection define-setter }
{ $subsection define-changer }
{ $subsection define-slot-methods }
{ $subsection define-accessors }
{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
@ -59,53 +120,32 @@ $low-level-note ;
HELP: reader-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
HELP: reader-quot
{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
HELP: slot-reader
{ $class-description "The class of slot reader words." }
{ $examples
{ $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
} ;
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." }
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: writer-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: slot-writer
{ $class-description "The class of slot writer words." }
{ $examples
{ $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
} ;
HELP: define-writer
{ $values { "class" class } { "spec" slot-spec } }
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slot
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
HELP: define-slot-methods
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slots
HELP: define-accessors
{ $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Defines a set of slot reader/writer words." }
{ $description "Defines slot methods." }
$low-level-note ;
HELP: simple-slots
{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
HELP: slot ( obj m -- value )
{ $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
{ $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
@ -116,18 +156,6 @@ HELP: set-slot ( value obj n -- )
{ $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
HELP: slot-of-reader
{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
HELP: slot-of-writer
{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
HELP: reader-word
{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
HELP: writer-word
{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
HELP: slot-named
{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " with the given name." } ;

148
core/slots/slots.factor
View File

@ -16,9 +16,6 @@ C: <slot-spec> slot-spec
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
: reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ;
: reader-quot ( decl -- quot )
[
\ slot ,
@ -26,91 +23,62 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over slot-spec-reader
swap "declared-effect" set-word-prop
slot-spec-reader swap "reading" set-word-prop ;
: define-reader ( class spec -- )
dup slot-spec-reader [
[ set-reader-props ] 2keep
dup slot-spec-offset
over slot-spec-reader
rot slot-spec-type reader-quot
define-slot-word
] [
2drop
] if ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over slot-spec-writer
swap "declared-effect" set-word-prop
slot-spec-writer swap "writing" set-word-prop ;
: define-writer ( class spec -- )
dup slot-spec-writer [
[ set-writer-props ] 2keep
dup slot-spec-offset
swap slot-spec-writer
[ set-slot ]
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 word-vocabulary >r >r word-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 ;
: short-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: long-slot ( spec # -- spec )
>r [ dup array? [ first2 create ] when ] map first4 r>
-rot <slot-spec> ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map [
{
{ [ over not ] [ 2drop f ] }
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] subset nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
: slot-named ( string specs -- spec/f )
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-effect T{ effect f { "object" } { "value" } } ; inline
: reader-word ( name -- word )
">>" append reader-effect create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
: writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word )
"(>>" swap ")" 3append writer-effect create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
"change-" prepend changer-effect create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
[ r> call r> swap ] %
swap setter-word ,
] [ ] make define-inline
] [ 2drop ] if ;
: define-slot-methods ( class slot name -- )
dup define-changer
dup define-setter
3dup define-reader
define-writer ;
: define-accessors ( class specs -- )
[
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;

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

@ -1,4 +1,4 @@
USING: splitting tools.test ;
USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
@ -56,3 +56,9 @@ unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
[ { V{ "a" "b" } V{ f f } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
] unit-test

2
core/splitting/splitting.factor
View File

@ -17,7 +17,7 @@ M: groups length
dup groups-seq length swap groups-n [ + 1- ] keep /i ;
M: groups set-length
[ groups-n * ] keep delegate set-length ;
[ groups-n * ] keep groups-seq set-length ;
: group@ ( n groups -- from to seq )
[ groups-n [ * dup ] keep + ] keep

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

@ -227,6 +227,9 @@ HELP: foldable
}
"The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them."
}
{ $notes
"Folding optimizations are not applied if the call site of a word is in the same source file as the word. This is a side-effect of the compilation unit system; see " { $link "compilation-units" } "."
}
{ $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ;
HELP: flushable
@ -556,10 +559,17 @@ HELP: PREDICATE:
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
{ $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." } ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }

1
core/syntax/syntax.factor
View File

@ -165,6 +165,7 @@ IN: bootstrap.syntax
"ERROR:" [
CREATE-CLASS dup ";" parse-tokens define-tuple-class
dup save-location
dup [ construct-boa throw ] curry define
] define-syntax

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

@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: tuples
ARTICLE: "tuple-constructors" "Constructors and slots"
"Tuples are created by calling one of a number of words:"
ARTICLE: "tuple-constructors" "Constructors"
"Tuples are created by calling one of two words:"
{ $subsection construct-empty }
{ $subsection construct-boa }
{ $subsection construct }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"A shortcut for defining BOA constructors:"
@ -19,18 +18,13 @@ $nl
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
""
": <rgb>"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
": <rgb> f <rgba> ; ! identical to above"
": <rgb> f <rgba> ;"
""
": <color> construct-empty ;"
": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above"
}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
} ;
ARTICLE: "tuple-delegation" "Delegation"
ARTICLE: "tuple-delegation" "Tuple delegation"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
{ $subsection delegate }
{ $subsection set-delegate }
@ -48,7 +42,7 @@ $nl
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
"{ 1 0 0 } <colored> \"my-shape\" set"
"\"my-ellipse\" get \"my-shape\" get set-delegate"
"\"my-shape\" get dup colored-color swap ellipse-center .s"
"\"my-shape\" get dup color>> swap center>> .s"
"{ 0 0 }\n{ 1 0 0 }"
} ;
@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
{ $subsection tuple>array }
{ $subsection tuple-slots }
"Tuple classes can also be defined at run time:"
{ $subsection define-tuple-class } ;
{ $subsection define-tuple-class }
{ $see-also "slots" "mirrors" } ;
ARTICLE: "tuple-examples" "Tuple examples"
"An example:"
{ $code "TUPLE: employee name salary position ;" }
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
{ { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
{ { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
{ { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
" employee construct-empty ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
" employee construct-empty"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
{ $code
": <manager> ( -- manager )"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
" 40000 employee construct-boa ;"
}
"Now we can define more specific constructors:"
{ $code
": <manager> ( name -- person )"
" \"manager\" <person> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
""
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
" checks counter check construct-boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
}
"An example of using a changer:"
{ $code
": positions"
" {"
" \"junior programmer\""
" \"senior programmer\""
" \"project manager\""
" \"department manager\""
" \"executive\""
" \"CTO\""
" \"CEO\""
" \"enterprise Java world dictator\""
" } ;"
""
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
} ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
"Tuples are user-defined classes composed of named slots."
{ $subsection "tuple-examples" }
"A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
{ $code "TUPLE: person name address phone ;" "C: <person> person" }
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }
{ { $snippet "person-address" } { $snippet "set-person-address" } }
{ { $snippet "person-phone" } { $snippet "set-person-phone" } }
}
"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
$nl
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Further topics:"
{ $subsection "tuple-delegation" }
{ $subsection "tuple-introspection" } ;
{ $subsection "tuple-introspection" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"

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

@ -5,9 +5,6 @@ generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ;
IN: tuples.tests
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: rect x y w h ;
: <rect> rect construct-boa ;
@ -90,12 +87,6 @@ TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } ]
[ T{ delegate-clone T{ empty f } } clone ] unit-test
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
! Compiler regression
[ t length ] [ no-method-object t eq? ] must-fail-with
@ -121,7 +112,7 @@ TUPLE: yo-momma ;
[
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma typemap get values memq? ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
@ -236,7 +227,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with
] [ [ no-tuple-class? ] is? ] must-fail-with
! Hardcore unit tests
USE: threads

10
core/tuples/tuples.factor
View File

@ -3,7 +3,8 @@
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.private compiler.units ;
classes classes.private slots slots.deprecated slots.private
compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
@ -85,13 +86,14 @@ PRIVATE>
dupd 4 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
define-slots ;
2dup define-slots
define-accessors ;
TUPLE: check-tuple class ;
ERROR: no-tuple-class class ;
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ \ check-tuple construct-boa throw ] if ;
[ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- )
2dup check-shape

4
core/vocabs/loader/loader.factor
View File

@ -113,7 +113,11 @@ M: string (load-vocab)
rethrow
] [
drop
dup find-vocab-root [
[ (load-vocab) ] with-compiler-errors
] [
dup vocab [ drop ] [ no-vocab ] if
] if
] if
] with-compiler-errors
] load-vocab-hook set-global

11
core/vocabs/vocabs.factor
View File

@ -7,8 +7,7 @@ IN: vocabs
SYMBOL: dictionary
TUPLE: vocab
name root
words
name words
main help
source-loaded? docs-loaded? ;
@ -60,16 +59,12 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
TUPLE: no-vocab name ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ no-vocab ] ?if ;
dup load-vocab-hook get call vocab ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;

11
core/words/words.factor
View File

@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
M: word definition word-def ;
TUPLE: undefined ;
: undefined ( -- * ) \ undefined construct-empty throw ;
ERROR: undefined ;
PREDICATE: word deferred ( obj -- ? )
word-def [ undefined ] = ;
@ -189,12 +187,11 @@ M: word subwords drop f ;
[ ] [ no-vocab ] ?if
set-at ;
TUPLE: check-create name vocab ;
ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
2dup [ string? ] both? [
\ check-create construct-boa throw
] unless ;
2dup [ string? ] both?
[ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup

6
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
hints unicode.case continuations io.encodings.latin1 ;
hints unicode.case continuations io.encodings.ascii ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
@ -32,8 +32,8 @@ HINTS: do-line vector string ;
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
latin1 <file-writer> [
swap latin1 <file-reader> [
ascii <file-writer> [
swap ascii <file-reader> [
swap <duplex-stream> [
500000 <vector> (reverse-complement)
] with-stream

2
extra/builder/util/util.factor
View File

@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
sequences.deep new-slots accessors assocs.lib
sequences.deep accessors assocs.lib
io.encodings.utf8
combinators.cleave bake calendar calendar.format ;

15
extra/bunny/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-random? f }
{ deploy-name "Bunny" }
{ deploy-threads? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-io 3 }
{ deploy-compiler? t }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
}

2
extra/cairo/lib/lib.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math combinators.cleave shuffle new-slots
kernel libc locals math combinators.cleave shuffle
accessors ;
IN: cairo.lib

2
extra/cairo/png/png.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.cleave kernel new-slots
USING: arrays combinators.cleave kernel
accessors math ui.gadgets ui.render opengl.gl byte-arrays
namespaces opengl cairo.ffi cairo.lib ;
IN: cairo.png

2
extra/calendar/calendar.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel math math.functions namespaces sequences
strings tuples system vocabs.loader calendar.backend threads
new-slots accessors combinators locals ;
accessors combinators locals ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;

5
extra/combinators/lib/lib-tests.factor
View File

@ -46,3 +46,8 @@ IN: combinators.lib.tests
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
{ 1 1 } [
[ even? ] [ drop 1 ] [ drop 2 ] ifte
] must-infer-as

2
extra/concurrency/distributed/distributed.factor
View File

@ -3,7 +3,7 @@
USING: serialize sequences concurrency.messaging
threads io io.server qualified arrays
namespaces kernel io.encodings.binary combinators.cleave
new-slots accessors ;
accessors ;
QUALIFIED: io.sockets
IN: concurrency.distributed

4
extra/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -49,8 +49,8 @@ HELP: while-mailbox-empty
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ $values { "mailbox" mailbox }
{ "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;

14
extra/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -16,9 +16,9 @@ tools.test math kernel strings ;
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
@ -27,10 +27,10 @@ tools.test math kernel strings ;
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put

18
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -17,17 +17,17 @@ TUPLE: mailbox threads data ;
[ mailbox-data push-front ] keep
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
: block-unless-pred ( mailbox timeout pred -- )
pick mailbox-data over dlist-contains? [
3drop
] [
2dup >r mailbox-threads r> "mailbox" wait
>r over mailbox-threads over "mailbox" wait r>
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait
over mailbox-threads over "mailbox" wait
block-if-empty
] [
drop
@ -58,12 +58,12 @@ TUPLE: mailbox threads data ;
2drop
] if ; inline
: mailbox-get-timeout? ( pred mailbox timeout -- obj )
[ block-unless-pred ] 3keep drop
mailbox-data delete-node-if ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
3dup block-unless-pred
nip >r mailbox-data r> delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
: mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline
TUPLE: linked-error thread ;

6
extra/concurrency/messaging/messaging.factor
View File

@ -26,10 +26,10 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
my-mailbox mailbox-get? ?linked ; inline
my-mailbox swap mailbox-get? ?linked ; inline
: receive-if-timeout ( pred timeout -- message )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ;

2
extra/db/db.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings
tools.walker new-slots accessors ;
tools.walker accessors ;
IN: db
TUPLE: db

2
extra/db/postgresql/lib/lib.factor
View File

@ -4,7 +4,7 @@ USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser
combinators combinators.cleave libc shuffle calendar.format
byte-arrays destructors prettyprint new-slots accessors
byte-arrays destructors prettyprint accessors
strings serialize io.encodings.binary io.streams.byte-array ;
IN: db.postgresql.lib

2
extra/digraphs/digraphs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel new-slots sequences vectors ;
USING: accessors assocs kernel sequences vectors ;
IN: digraphs
TUPLE: digraph ;

8
extra/graphics/bitmap/bitmap.factor Normal file → Executable file
View File

@ -117,16 +117,16 @@ M: bitmap height ( bitmap -- ) bitmap-height ;
load-bitmap [ <graphics-gadget> "bitmap" open-window ] keep ;
: test-bitmap24 ( -- )
"misc/graphics/bmps/thiswayup24.bmp" resource-path bitmap. ;
"extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ;
: test-bitmap8 ( -- )
"misc/graphics/bmps/rgb8bit.bmp" resource-path bitmap. ;
"extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ;
: test-bitmap4 ( -- )
"misc/graphics/bmps/rgb4bit.bmp" resource-path
"extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path
load-bitmap ;
! bitmap. ;
: test-bitmap1 ( -- )
"misc/graphics/bmps/1bit.bmp" resource-path bitmap. ;
"extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ;

0
misc/graphics/bmps/1bit.bmp → extra/graphics/bitmap/test-images/1bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

0
misc/graphics/bmps/rgb4bit.bmp → extra/graphics/bitmap/test-images/rgb4bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

0
misc/graphics/bmps/rgb8bit.bmp → extra/graphics/bitmap/test-images/rgb8bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

0
misc/graphics/bmps/thiswayup24.bmp → extra/graphics/bitmap/test-images/thiswayup24.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 59 KiB

After

Width:  |  Height:  |  Size: 59 KiB

13
extra/hello-ui/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 1 }
{ deploy-compiler? t }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-random? f }
{ deploy-name "Hello world" }
{ deploy-c-types? f }
{ deploy-ui? t }
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 1 }
{ deploy-reflection 1 }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
}

11
extra/hello-world/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
{ deploy-random? f }
{ deploy-name "Hello world (console)" }
{ deploy-threads? f }
{ deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-ui? f }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ deploy-reflection 1 }
{ deploy-ui? f }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
}

4
extra/help/help.factor
View File

@ -25,10 +25,6 @@ GENERIC: word-help* ( word -- content )
M: word word-help* drop f ;
M: slot-reader word-help* drop \ $slot-reader ;
M: slot-writer word-help* drop \ $slot-writer ;
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )

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

@ -39,8 +39,6 @@ IN: help.lint
{
$shuffle
$values-x/y
$slot-reader
$slot-writer
$predicate
$class-description
$error-description

12
extra/help/markup/markup-tests.factor
View File

@ -4,18 +4,6 @@ IN: help.markup.tests
TUPLE: blahblah quux ;
: test-slot blahblah "slots" word-prop second ;
[
{ { "blahblah" { $instance blahblah } } { "quux" { $instance object } } }
] [
test-slot blahblah ($spec-reader-values)
] unit-test
[ ] [
test-slot blahblah $spec-reader-values
] unit-test
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ blahblah-quux help ] unit-test

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

@ -296,63 +296,6 @@ M: string ($instance)
{ $link with-pprint } " combinator."
} $notes ;
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
[ { $instance } swap add ] 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 slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $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 slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $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 ;
GENERIC: elements* ( elt-type element -- )
M: simple-element elements* [ elements* ] with each ;

6
extra/http/client/client.factor
View File

@ -3,7 +3,7 @@
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors
io.encodings.latin1 io.encodings.binary fry ;
io.encodings.8-bit io.encodings.binary fry ;
IN: http.client
DEFER: http-request
@ -52,7 +52,7 @@ PRIVATE>
: http-request ( request -- response stream )
dup request [
dup request-addr latin1 <client>
dup request-addr iso-8859-1 <client>
1 minutes over set-timeout
[
write-request flush
@ -82,7 +82,7 @@ PRIVATE>
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
swap http-get-stream swap check-response
[ swap latin1 <file-writer> stream-copy ] with-disposal ;
[ swap iso-8859-1 <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;

2
extra/http/http.factor
View File

@ -3,7 +3,7 @@
USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
combinators vectors sorting accessors calendar
calendar.format quotations arrays combinators.cleave
combinators.lib byte-arrays ;
IN: http

2
extra/http/server/actions/actions.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
USING: accessors sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations locals ;
IN: http.server.actions

Some files were not shown because too many files have changed in this diff Show More