Merge branch 'master' of git://factorcode.org/git/factor
Matthew Willis
commit
297978b7d2
|
|
@ -18,4 +18,4 @@ factor
|
|||
temp
|
||||
logs
|
||||
work
|
||||
misc/wordsize
|
||||
buildsupport/wordsize
|
||||
|
|
|
|||
8
Makefile
8
Makefile
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
|
|||
|
||||
HELP: load-library
|
||||
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
|
||||
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
|
||||
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
|
||||
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
|
||||
|
||||
HELP: add-library
|
||||
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
|
||||
|
|
@ -211,8 +210,9 @@ $nl
|
|||
ARTICLE: "alien-callback" "Calling Factor from C"
|
||||
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
|
||||
{ $subsection alien-callback }
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
{ $subsection "alien-callback-gc" } ;
|
||||
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
{ $subsection "alien-callback-gc" }
|
||||
{ $see-also "byte-arrays-gc" } ;
|
||||
|
||||
ARTICLE: "dll.private" "DLL handles"
|
||||
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
|
||||
|
|
@ -291,7 +291,7 @@ $nl
|
|||
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
|
||||
$nl
|
||||
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
|
||||
{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
|
||||
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
|
||||
{ $subsection "loading-libs" }
|
||||
{ $subsection "alien-invoke" }
|
||||
{ $subsection "alien-callback" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: alien.tests
|
||||
USING: alien alien.accessors byte-arrays arrays kernel
|
||||
kernel.private namespaces tools.test sequences libc math system
|
||||
prettyprint layouts ;
|
||||
USING: alien alien.accessors alien.syntax byte-arrays arrays
|
||||
kernel kernel.private namespaces tools.test sequences libc math
|
||||
system prettyprint layouts ;
|
||||
|
||||
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
||||
|
||||
|
|
@ -68,3 +68,7 @@ cell 8 = [
|
|||
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
|
||||
|
||||
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
|
||||
|
||||
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
|
||||
|
||||
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math namespaces sequences system
|
||||
kernel.private tuples bit-arrays byte-arrays float-arrays ;
|
||||
kernel.private tuples bit-arrays byte-arrays float-arrays
|
||||
arrays ;
|
||||
IN: alien
|
||||
|
||||
! Some predicate classes used by the compiler for optimization
|
||||
|
|
@ -57,28 +58,28 @@ TUPLE: library path abi dll ;
|
|||
over dup [ dlopen ] when \ library construct-boa ;
|
||||
|
||||
: load-library ( name -- dll )
|
||||
library library-dll ;
|
||||
library dup [ library-dll ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -158,6 +158,19 @@ HELP: define-out
|
|||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||
$nl
|
||||
"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
|
||||
{ $list
|
||||
"the C function returns"
|
||||
"the C function calls Factor code via a callback"
|
||||
}
|
||||
"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
|
||||
$nl
|
||||
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
|
||||
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
|
||||
|
||||
ARTICLE: "c-out-params" "Output parameters in C"
|
||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||
$nl
|
||||
|
|
@ -229,13 +242,11 @@ $nl
|
|||
{ $subsection <c-object> }
|
||||
{ $subsection <c-array> }
|
||||
{ $warning
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
|
||||
$nl
|
||||
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
|
||||
{ $see-also "c-arrays" } ;
|
||||
|
||||
ARTICLE: "malloc" "Manual memory management"
|
||||
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
|
||||
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
|
||||
$nl
|
||||
"Allocating a C datum with a fixed address:"
|
||||
{ $subsection malloc-object }
|
||||
|
|
@ -245,8 +256,6 @@ $nl
|
|||
{ $subsection malloc }
|
||||
{ $subsection calloc }
|
||||
{ $subsection realloc }
|
||||
"The return value of the above three words must always be checked for a memory allocation failure:"
|
||||
{ $subsection check-ptr }
|
||||
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||
{ $subsection free }
|
||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||
|
|
@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
|
|||
{ $subsection string>u16-alien }
|
||||
{ $subsection malloc-char-string }
|
||||
{ $subsection malloc-u16-string }
|
||||
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
|
||||
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
|
||||
{ $subsection alien>char-string }
|
||||
{ $subsection alien>u16-string } ;
|
||||
{ $subsection alien>u16-string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
$nl
|
||||
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
|
||||
{ $subsection "c-types-specs" }
|
||||
{ $subsection "c-byte-arrays" }
|
||||
{ $subsection "malloc" }
|
||||
{ $subsection "c-strings" }
|
||||
{ $subsection "c-arrays" }
|
||||
{ $subsection "c-out-params" }
|
||||
"Important guidelines for passing data in byte arrays:"
|
||||
{ $subsection "byte-arrays-gc" }
|
||||
"C-style enumerated types are supported:"
|
||||
{ $subsection POSTPONE: C-ENUM: }
|
||||
"C types can be aliased for convenience and consitency with native library documentation:"
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
@ -262,8 +260,8 @@ M: long-long-type box-return ( type -- )
|
|||
r> add*
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien )
|
||||
binary file-contents malloc-byte-array ;
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents dup malloc-byte-array swap length ;
|
||||
|
||||
[
|
||||
[ alien-cell ]
|
||||
|
|
|
|||
|
|
@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
|||
|
||||
! Hack; if we're on ARM, we probably don't have much RAM, so
|
||||
! skip this test.
|
||||
cpu "arm" = [
|
||||
[ "testing" ] [
|
||||
"testing" callback-5a callback_test_1
|
||||
] unit-test
|
||||
] unless
|
||||
! cpu "arm" = [
|
||||
! [ "testing" ] [
|
||||
! "testing" callback-5a callback_test_1
|
||||
! ] unit-test
|
||||
! ] unless
|
||||
|
||||
: callback-6
|
||||
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
@ -32,7 +32,7 @@ PRIVATE>
|
|||
>r >r swapd roll indirect-quot r> r>
|
||||
-rot define-declared ;
|
||||
|
||||
: DLL" skip-blank parse-string dlopen parsed ; parsing
|
||||
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
||||
|
||||
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
malloc free memcpy
|
||||
malloc calloc free memcpy
|
||||
} compile
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -349,7 +349,7 @@ M: curry '
|
|||
[
|
||||
{
|
||||
dictionary source-files
|
||||
typemap builtins class<map update-map
|
||||
typemap builtins class<map class-map update-map
|
||||
} [ dup get swap bootstrap-word set ] each
|
||||
] H{ } make-assoc
|
||||
bootstrap-global set
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -30,6 +30,10 @@ crossref off
|
|||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
H{ } clone dictionary set
|
||||
H{ } clone changed-words set
|
||||
H{ } clone root-cache set
|
||||
|
||||
! 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.
|
||||
|
|
@ -87,15 +91,12 @@ call
|
|||
"words.private"
|
||||
"vectors"
|
||||
"vectors.private"
|
||||
} [
|
||||
dup find-vocab-root swap create-vocab
|
||||
[ set-vocab-root ] keep
|
||||
f swap set-vocab-source-loaded?
|
||||
] each
|
||||
} [ create-vocab drop ] each
|
||||
|
||||
H{ } clone source-files set
|
||||
H{ } clone class<map set
|
||||
H{ } clone update-map set
|
||||
H{ } clone class<map set
|
||||
H{ } clone class-map set
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
|
|
@ -550,7 +551,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "eq?" "kernel" }
|
||||
{ "getenv" "kernel.private" }
|
||||
{ "setenv" "kernel.private" }
|
||||
{ "(stat)" "io.files.private" }
|
||||
{ "(exists?)" "io.files.private" }
|
||||
{ "(directory)" "io.files.private" }
|
||||
{ "data-gc" "memory" }
|
||||
{ "code-gc" "memory" }
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
|
|||
"listener" vocab
|
||||
[ restarts. vocab-main execute ]
|
||||
[ die ] if*
|
||||
1 exit
|
||||
] recover
|
||||
] [
|
||||
"Cannot find " write write "." print
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -25,7 +25,7 @@ SYMBOL: bootstrap-time
|
|||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||
seq-diff
|
||||
[ "bootstrap." swap append require ] each ;
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
: compile-remaining ( -- )
|
||||
"Compiling remaining words..." print flush
|
||||
|
|
@ -57,7 +57,7 @@ millis >r
|
|||
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"math help handbook compiler random tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
parse-command-line
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -3,9 +3,7 @@
|
|||
USING: words sequences vocabs kernel ;
|
||||
IN: bootstrap.syntax
|
||||
|
||||
"syntax" create-vocab
|
||||
"resource:core" over set-vocab-root
|
||||
f swap set-vocab-source-loaded?
|
||||
"syntax" create-vocab drop
|
||||
|
||||
{
|
||||
"!"
|
||||
|
|
@ -23,6 +21,7 @@ f swap set-vocab-source-loaded?
|
|||
"C:"
|
||||
"CHAR:"
|
||||
"DEFER:"
|
||||
"ERROR:"
|
||||
"F{"
|
||||
"FV{"
|
||||
"FORGET:"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien arrays definitions generic assocs hashtables io
|
||||
kernel math namespaces parser prettyprint sequences strings
|
||||
tools.test vectors words quotations classes io.streams.string
|
||||
tools.test vectors words quotations classes
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units ;
|
||||
IN: classes.tests
|
||||
|
|
@ -22,12 +22,16 @@ H{ } "s" set
|
|||
[ 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
|
||||
|
|
@ -61,10 +65,6 @@ UNION: c a b ;
|
|||
UNION: bah fixnum alien ;
|
||||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
||||
! Test redefinition of classes
|
||||
UNION: union-1 fixnum float ;
|
||||
|
||||
|
|
@ -178,6 +178,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
|
|||
|
||||
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
|
||||
|
||||
USE: io.streams.string
|
||||
|
||||
2 [
|
||||
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||
|
||||
|
|
@ -222,3 +224,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
|||
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||
|
||||
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ;
|
|||
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
|
||||
|
||||
SYMBOL: typemap
|
||||
SYMBOL: class-map
|
||||
SYMBOL: class<map
|
||||
SYMBOL: update-map
|
||||
SYMBOL: builtins
|
||||
|
||||
PREDICATE: word builtin-class
|
||||
PREDICATE: class builtin-class
|
||||
"metaclass" word-prop builtin-class eq? ;
|
||||
|
||||
PREDICATE: class tuple-class
|
||||
|
|
@ -58,6 +59,7 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
|
|||
{ [ dup builtin-class? ] [ dup set ] }
|
||||
{ [ dup members ] [ members [ (flatten-class) ] each ] }
|
||||
{ [ dup superclass ] [ superclass (flatten-class) ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: flatten-class ( class -- assoc )
|
||||
|
|
@ -108,11 +110,31 @@ DEFER: (class<)
|
|||
: 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-builtin-class ] 2apply union lookup-union ;
|
||||
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
|
||||
|
||||
: (class-and) ( class class -- class )
|
||||
[ flatten-builtin-class ] 2apply intersect lookup-union ;
|
||||
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 ;
|
||||
|
|
@ -219,9 +241,16 @@ M: word reset-class drop ;
|
|||
: 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+ update-map+ ;
|
||||
dup typemap+ dup class-map+ dup class<map+ update-map+ ;
|
||||
|
||||
: cache-classes ( assoc -- )
|
||||
[ drop cache-class ] assoc-each ;
|
||||
|
|
@ -229,7 +258,7 @@ M: word reset-class drop ;
|
|||
GENERIC: uncache-class ( class -- )
|
||||
|
||||
M: class uncache-class
|
||||
dup update-map- dup class<map- typemap- ;
|
||||
dup update-map- dup class<map- dup class-map- typemap- ;
|
||||
|
||||
M: word uncache-class drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ PREDICATE: class union-class
|
|||
drop [ drop f ]
|
||||
] [
|
||||
unclip first "predicate" word-prop swap
|
||||
[ >r "predicate" word-prop [ dup ] swap append r> ]
|
||||
[ >r "predicate" word-prop [ dup ] prepend r> ]
|
||||
assoc-map alist>quot
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -80,7 +76,7 @@ M: hashtable hashcode*
|
|||
|
||||
: hash-case-quot ( default assoc -- quot )
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append ;
|
||||
[ dup hashcode >fixnum ] prepend ;
|
||||
|
||||
: contiguous-range? ( keys -- from to ? )
|
||||
dup [ fixnum? ] all? [
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@ splitting io.files ;
|
|||
|
||||
: run-bootstrap-init ( -- )
|
||||
"user-init" get [
|
||||
home ".factor-boot-rc" path+ ?run-file
|
||||
home ".factor-boot-rc" append-path ?run-file
|
||||
] when ;
|
||||
|
||||
: run-user-init ( -- )
|
||||
"user-init" get [
|
||||
home ".factor-rc" path+ ?run-file
|
||||
home ".factor-rc" append-path ?run-file
|
||||
] when ;
|
||||
|
||||
: cli-var-param ( name value -- ) swap set-global ;
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -261,7 +261,7 @@ cell 8 = [
|
|||
: compiled-fixnum* fixnum* ;
|
||||
|
||||
: test-fixnum*
|
||||
(random) >fixnum (random) >fixnum
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
[ 2drop ] [ "Oops" throw ] if ;
|
||||
|
|
@ -271,7 +271,7 @@ cell 8 = [
|
|||
: compiled-fixnum>bignum fixnum>bignum ;
|
||||
|
||||
: test-fixnum>bignum
|
||||
(random) >fixnum
|
||||
32 random-bits >fixnum
|
||||
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
|
|
@ -280,7 +280,7 @@ cell 8 = [
|
|||
: compiled-bignum>fixnum bignum>fixnum ;
|
||||
|
||||
: test-bignum>fixnum
|
||||
5 random [ drop (random) ] map product >bignum
|
||||
5 random [ drop 32 random-bits ] map product >bignum
|
||||
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
|
|
@ -385,7 +385,7 @@ cell 8 = [
|
|||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||
|
||||
: xword-def word-def [ { fixnum } declare ] swap append ;
|
||||
: xword-def word-def [ { fixnum } declare ] prepend ;
|
||||
|
||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -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" } "):"
|
||||
|
|
|
|||
|
|
@ -29,7 +29,9 @@ $nl
|
|||
{ $subsection ignore-errors }
|
||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||
{ $subsection "errors-restartable" }
|
||||
{ $subsection "errors-post-mortem" } ;
|
||||
{ $subsection "errors-post-mortem" }
|
||||
"When Factor encouters a critical error, it calls the following word:"
|
||||
{ $subsection die } ;
|
||||
|
||||
ARTICLE: "continuations.private" "Continuation implementation details"
|
||||
"A continuation is simply a tuple holding the contents of the five stacks:"
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 define-method" ;
|
||||
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 ( -- )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: definitions.tests
|
||||
USING: tools.test generic kernel definitions sequences
|
||||
compiler.units ;
|
||||
compiler.units words ;
|
||||
|
||||
TUPLE: combination-1 ;
|
||||
|
||||
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
|
||||
M: combination-1 perform-combination 2drop [ ] ;
|
||||
|
||||
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ SYMBOL: generic-1
|
|||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
[ ] object \ generic-1 define-method
|
||||
object \ generic-1 create-method [ ] define
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ $nl
|
|||
{ $subsection define-generic }
|
||||
{ $subsection define-simple-generic }
|
||||
"Methods can be added to existing generic words:"
|
||||
{ $subsection define-method }
|
||||
{ $subsection create-method }
|
||||
"Method definitions can be looked up:"
|
||||
{ $subsection method }
|
||||
{ $subsection methods }
|
||||
|
|
@ -123,10 +123,10 @@ HELP: method
|
|||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." } ;
|
||||
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
{ 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
|
||||
|
|
@ -140,16 +140,17 @@ HELP: order
|
|||
HELP: check-method
|
||||
{ $values { "class" class } { "generic" generic } }
|
||||
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
|
||||
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
|
||||
{ $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 ;
|
||||
|
||||
HELP: define-method
|
||||
{ $values { "quot" quotation } { "class" class } { "generic" generic } }
|
||||
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
|
||||
HELP: create-method
|
||||
{ $values { "class" class } { "generic" generic } { "method" method-body } }
|
||||
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
|
||||
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
|
||||
|
||||
HELP: implementors
|
||||
{ $values { "class" class } { "seq" "a sequence of generic words" } }
|
||||
|
|
|
|||
|
|
@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
|
|||
\ = usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
||||
] unit-test
|
||||
|
||||
GENERIC: generic-forget-test-3
|
||||
|
||||
M: f generic-forget-test-3 ;
|
||||
|
||||
[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
|
||||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
|
||||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ f ] [ f generic-forget-test-3 ] unit-test
|
||||
|
||||
: a-word ;
|
||||
|
||||
GENERIC: a-generic
|
||||
|
||||
M: integer a-generic a-word ;
|
||||
|
||||
[ ] [ \ integer \ a-generic method "m" set ] unit-test
|
||||
|
||||
[ t ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
|
||||
|
||||
[ f ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
|
|
|||
|
|
@ -17,10 +17,6 @@ M: object perform-combination
|
|||
#! the method will throw an error. We don't want that.
|
||||
nip [ "Invalid method combination" throw ] curry [ ] like ;
|
||||
|
||||
GENERIC: method-prologue ( class combination -- quot )
|
||||
|
||||
M: object method-prologue 2drop [ ] ;
|
||||
|
||||
GENERIC: make-default-method ( generic combination -- method )
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
|
@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
|
|||
: check-method ( class generic -- class generic )
|
||||
over class? over generic? and [
|
||||
\ check-method construct-boa throw
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
: with-methods ( word quot -- )
|
||||
: with-methods ( generic quot -- )
|
||||
swap [ "methods" word-prop swap call ] keep make-generic ;
|
||||
inline
|
||||
|
||||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot class generic -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method-def" word-prop >boolean ;
|
||||
PREDICATE: word method-body
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
: method-word-props ( quot class generic -- assoc )
|
||||
: method-word-props ( class generic -- assoc )
|
||||
[
|
||||
"method-generic" set
|
||||
"method-class" set
|
||||
"method-def" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
: <method> ( class generic -- method )
|
||||
check-method
|
||||
[ make-method-def ] 3keep
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
tuck set-word-props
|
||||
dup rot define ;
|
||||
[ set-word-props ] keep ;
|
||||
|
||||
: redefine-method ( quot class generic -- )
|
||||
[ method swap "method-def" set-word-prop ] 3keep
|
||||
[ make-method-def ] 2keep
|
||||
method swap define ;
|
||||
: reveal-method ( method class generic -- )
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
2dup method [
|
||||
redefine-method
|
||||
: create-method ( class generic -- method )
|
||||
2dup method dup [
|
||||
2nip
|
||||
] [
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods
|
||||
drop [ <method> dup ] 2keep reveal-method
|
||||
] if ;
|
||||
|
||||
: <default-method> ( generic combination -- method )
|
||||
object bootstrap-word pick <method>
|
||||
[ -rot make-default-method define ] keep ;
|
||||
|
||||
: define-default-method ( generic combination -- )
|
||||
dupd make-default-method object bootstrap-word pick <method>
|
||||
"default-method" set-word-prop ;
|
||||
dupd <default-method> "default-method" set-word-prop ;
|
||||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
|
|
@ -108,30 +98,31 @@ M: method-spec set-where
|
|||
first2 method set-where ;
|
||||
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
first2 method definer ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup
|
||||
[ "method-def" word-prop ] when ;
|
||||
first2 method definition ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ forget-word ] [ drop ] if ;
|
||||
dup generic? [
|
||||
[ delete-at* ] with-methods
|
||||
[ forget-word ] [ drop ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
first2 method forget* ;
|
||||
|
||||
M: method-body definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method-def" word-prop ;
|
||||
|
||||
M: method-body forget*
|
||||
dup "method-class" word-prop
|
||||
swap "method-generic" word-prop
|
||||
forget-method ;
|
||||
dup "forgotten" word-prop [ drop ] [
|
||||
dup "method-class" word-prop
|
||||
over "method-generic" word-prop forget-method
|
||||
t "forgotten" set-word-prop
|
||||
] if ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
all-words [
|
||||
|
|
@ -163,16 +154,12 @@ M: assoc update-methods ( assoc -- )
|
|||
make-generic
|
||||
] if ;
|
||||
|
||||
GENERIC: subwords ( word -- seq )
|
||||
|
||||
M: word subwords drop f ;
|
||||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
dup subwords [ forget ] each (forget-word) ;
|
||||
|
||||
: xref-generics ( -- )
|
||||
all-words [ subwords [ xref ] each ] each ;
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -33,17 +33,14 @@ 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 ;
|
||||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ word-def ]
|
||||
[ 1quotation ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
|
|
@ -53,7 +50,7 @@ TUPLE: no-math-method left right generic ;
|
|||
2dup and [
|
||||
2dup math-upgrade >r
|
||||
math-class-max over order min-class applicable-method
|
||||
r> swap append
|
||||
r> prepend
|
||||
] [
|
||||
2drop object-method
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -8,10 +8,6 @@ IN: generic.standard
|
|||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
M: standard-combination method-prologue
|
||||
standard-combination-# object
|
||||
<array> swap add* [ declare ] curry ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
|
@ -30,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 ;
|
||||
|
|
@ -165,7 +158,7 @@ C: <hook-combination> hook-combination
|
|||
0 (dispatch#) [
|
||||
swap slip
|
||||
hook-combination-var [ get ] curry
|
||||
swap append
|
||||
prepend
|
||||
] with-variable ; inline
|
||||
|
||||
M: hook-combination make-default-method
|
||||
|
|
@ -174,7 +167,7 @@ M: hook-combination make-default-method
|
|||
M: hook-combination perform-combination
|
||||
[
|
||||
standard-methods
|
||||
[ [ drop ] swap append ] assoc-map
|
||||
[ [ drop ] prepend ] assoc-map
|
||||
single-combination
|
||||
] with-hook ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: heaps.tests
|
|||
: random-alist ( n -- alist )
|
||||
[
|
||||
[
|
||||
(random) dup number>string swap set
|
||||
32 random-bits dup number>string swap set
|
||||
] times
|
||||
] H{ } make-assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
|
|||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts ;
|
||||
system layouts vectors ;
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
|
|
@ -294,4 +294,6 @@ cell-bits 32 = [
|
|||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -354,7 +354,7 @@ M: object infer-call
|
|||
|
||||
\ setenv { object fixnum } { } <effect> set-primitive-effect
|
||||
|
||||
\ (stat) { string } { object object object object } <effect> set-primitive-effect
|
||||
\ exists? { string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ (directory) { string } { array } <effect> set-primitive-effect
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.encodings.binary SYMBOL: binary
|
||||
USING: io.encodings kernel ;
|
||||
IN: io.encodings.binary
|
||||
|
||||
TUPLE: binary ;
|
||||
M: binary <encoder> drop ;
|
||||
M: binary <decoder> drop ;
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
@ -44,25 +44,21 @@ $nl { $vocab-link "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."
|
||||
{ $subsection decode-step }
|
||||
{ $subsection init-decoder }
|
||||
{ $subsection stream-write-encoded } ;
|
||||
{ $subsection decode-char }
|
||||
{ $subsection encode-char }
|
||||
"The following methods are optional:"
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> } ;
|
||||
|
||||
HELP: decode-step ( buf char encoding -- )
|
||||
{ $values { "buf" "A string buffer which characters can be pushed to" }
|
||||
{ "char" "An octet which is read from a stream" }
|
||||
{ "encoding" "An encoding descriptor tuple" } }
|
||||
{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
|
||||
HELP: decode-char
|
||||
{ $values { "stream" "an underlying input stream" }
|
||||
{ "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: stream-write-encoded ( string stream encoding -- )
|
||||
{ $values { "string" "a string" }
|
||||
{ "stream" "an output stream" }
|
||||
HELP: encode-char
|
||||
{ $values { "char" "a character" }
|
||||
{ "stream" "an underlying output stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
|
||||
{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
|
||||
|
||||
HELP: init-decoder ( stream encoding -- encoding )
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
|
||||
|
||||
{ init-decoder decode-step stream-write-encoded } related-words
|
||||
{ encode-char decode-char } related-words
|
||||
|
|
|
|||
|
|
@ -2,62 +2,39 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces
|
||||
growable strings io classes continuations combinators
|
||||
io.styles io.streams.plain io.encodings.binary splitting
|
||||
io.streams.duplex byte-arrays ;
|
||||
io.styles io.streams.plain splitting
|
||||
io.streams.duplex byte-arrays sequences.private ;
|
||||
IN: io.encodings
|
||||
|
||||
! The encoding descriptor protocol
|
||||
|
||||
GENERIC: decode-step ( buf char encoding -- )
|
||||
M: object decode-step drop swap push ;
|
||||
GENERIC: decode-char ( stream encoding -- char/f )
|
||||
|
||||
GENERIC: init-decoder ( stream encoding -- encoding )
|
||||
M: tuple-class init-decoder construct-empty init-decoder ;
|
||||
M: object init-decoder nip ;
|
||||
GENERIC: encode-char ( char stream encoding -- )
|
||||
|
||||
GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
|
||||
M: object stream-write-encoded drop stream-write ;
|
||||
GENERIC: <decoder> ( stream encoding -- newstream )
|
||||
|
||||
: replacement-char HEX: fffd ;
|
||||
|
||||
TUPLE: decoder stream code cr ;
|
||||
|
||||
ERROR: decode-error ;
|
||||
|
||||
GENERIC: <encoder> ( stream encoding -- newstream )
|
||||
|
||||
TUPLE: encoder stream code ;
|
||||
|
||||
ERROR: encode-error ;
|
||||
|
||||
! Decoding
|
||||
|
||||
TUPLE: decode-error ;
|
||||
<PRIVATE
|
||||
|
||||
: decode-error ( -- * ) \ decode-error construct-empty throw ;
|
||||
M: tuple-class <decoder> construct-empty <decoder> ;
|
||||
M: tuple <decoder> f decoder construct-boa ;
|
||||
|
||||
SYMBOL: begin
|
||||
|
||||
: push-decoded ( buf ch -- buf ch state )
|
||||
over push 0 begin ;
|
||||
|
||||
: push-replacement ( buf -- buf ch state )
|
||||
! This is the replacement character
|
||||
HEX: fffd push-decoded ;
|
||||
|
||||
: space ( resizable -- room-left )
|
||||
dup underlying swap [ length ] 2apply - ;
|
||||
|
||||
: full? ( resizable -- ? ) space zero? ;
|
||||
|
||||
: end-read-loop ( buf ch state stream quot -- string/f )
|
||||
2drop 2drop >string f like ;
|
||||
|
||||
: decode-read-loop ( buf stream encoding -- string/f )
|
||||
pick full? [ 2drop >string ] [
|
||||
over stream-read1 [
|
||||
-rot tuck >r >r >r dupd r> decode-step r> r>
|
||||
decode-read-loop
|
||||
] [ 2drop >string f like ] if*
|
||||
] if ;
|
||||
|
||||
: decode-read ( length stream encoding -- string )
|
||||
rot <sbuf> -rot decode-read-loop ;
|
||||
|
||||
TUPLE: decoder code cr ;
|
||||
: <decoder> ( stream encoding -- newstream )
|
||||
dup binary eq? [ drop ] [
|
||||
dupd init-decoder { set-delegate set-decoder-code }
|
||||
decoder construct
|
||||
] if ;
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
{ decoder-stream decoder-code } get-slots ;
|
||||
|
||||
: cr+ t swap set-decoder-cr ; inline
|
||||
|
||||
|
|
@ -82,72 +59,78 @@ TUPLE: decoder code cr ;
|
|||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
swap stream-read1 [ add ] when*
|
||||
] [ nip ] if
|
||||
] [ nip ] if ;
|
||||
over stream-read1 [ add ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
: read-loop ( n stream -- string )
|
||||
SBUF" " clone [
|
||||
[
|
||||
>r nip stream-read1 dup
|
||||
[ r> push f ] [ r> 2drop t ] if
|
||||
] 2curry find-integer drop
|
||||
] keep "" like f like ;
|
||||
|
||||
M: decoder stream-read
|
||||
tuck { delegate decoder-code } get-slots decode-read fix-read ;
|
||||
tuck read-loop fix-read ;
|
||||
|
||||
M: decoder stream-read-partial stream-read ;
|
||||
|
||||
: decoder-read-until ( stream delim -- ch )
|
||||
! Copied from { c-reader stream-read-until }!!!
|
||||
over stream-read1 dup [
|
||||
dup pick memq? [ 2nip ] [ , decoder-read-until ] if
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
: (read-until) ( buf quot -- string/f sep/f )
|
||||
! quot: -- char stop?
|
||||
dup call
|
||||
[ >r drop "" like r> ]
|
||||
[ pick push (read-until) ] if ; inline
|
||||
|
||||
M: decoder stream-read-until
|
||||
! Copied from { c-reader stream-read-until }!!!
|
||||
[ swap decoder-read-until ] "" make
|
||||
swap over empty? over not and [ 2drop f f ] when ;
|
||||
SBUF" " clone -rot >decoder<
|
||||
[ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
|
||||
(read-until) ;
|
||||
|
||||
: fix-read1 ( stream char -- char )
|
||||
over decoder-cr [
|
||||
over cr-
|
||||
dup CHAR: \n = [
|
||||
drop stream-read1
|
||||
] [ nip ] if
|
||||
] [ nip ] if ;
|
||||
drop dup stream-read1
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
M: decoder stream-read1
|
||||
1 swap stream-read f like [ first ] [ f ] if* ;
|
||||
dup >decoder< decode-char fix-read1 ;
|
||||
|
||||
M: decoder stream-readln ( stream -- str )
|
||||
"\r\n" over stream-read-until handle-readln ;
|
||||
|
||||
M: decoder dispose decoder-stream dispose ;
|
||||
|
||||
! Encoding
|
||||
M: tuple-class <encoder> construct-empty <encoder> ;
|
||||
M: tuple <encoder> encoder construct-boa ;
|
||||
|
||||
TUPLE: encode-error ;
|
||||
|
||||
: encode-error ( -- * ) \ encode-error construct-empty throw ;
|
||||
|
||||
TUPLE: encoder code ;
|
||||
: <encoder> ( stream encoding -- newstream )
|
||||
dup binary eq? [ drop ] [
|
||||
construct-empty { set-delegate set-encoder-code }
|
||||
encoder construct
|
||||
] if ;
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
{ encoder-stream encoder-code } get-slots ;
|
||||
|
||||
M: encoder stream-write1
|
||||
>r 1string r> stream-write ;
|
||||
>encoder< encode-char ;
|
||||
|
||||
M: encoder stream-write
|
||||
{ delegate encoder-code } get-slots stream-write-encoded ;
|
||||
>encoder< [ encode-char ] 2curry each ;
|
||||
|
||||
M: encoder dispose delegate dispose ;
|
||||
M: encoder dispose encoder-stream dispose ;
|
||||
|
||||
M: encoder stream-flush encoder-stream stream-flush ;
|
||||
|
||||
INSTANCE: encoder plain-writer
|
||||
|
||||
! Rebinding duplex streams which have not read anything yet
|
||||
|
||||
: reencode ( stream encoding -- newstream )
|
||||
over encoder? [ >r delegate r> ] when <encoder> ;
|
||||
over encoder? [ >r encoder-stream r> ] when <encoder> ;
|
||||
|
||||
: redecode ( stream encoding -- newstream )
|
||||
over decoder? [ >r delegate r> ] when <decoder> ;
|
||||
over decoder? [ >r decoder-stream r> ] when <decoder> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
|
||||
tuck reencode >r redecode r> <duplex-stream> ;
|
||||
|
|
|
|||
|
|
@ -6,82 +6,68 @@ IN: io.encodings.utf8
|
|||
|
||||
! Decoding UTF-8
|
||||
|
||||
TUPLE: utf8 ch state ;
|
||||
TUPLE: utf8 ;
|
||||
|
||||
SYMBOL: double
|
||||
SYMBOL: triple
|
||||
SYMBOL: triple2
|
||||
SYMBOL: quad
|
||||
SYMBOL: quad2
|
||||
SYMBOL: quad3
|
||||
<PRIVATE
|
||||
|
||||
: starts-2? ( char -- ? )
|
||||
-6 shift BIN: 10 number= ;
|
||||
dup [ -6 shift BIN: 10 number= ] when ;
|
||||
|
||||
: append-nums ( buf bottom top state-out -- buf num state )
|
||||
>r over starts-2?
|
||||
[ 6 shift swap BIN: 111111 bitand bitor r> ]
|
||||
[ r> 3drop push-replacement ] if ;
|
||||
: append-nums ( stream byte -- stream char )
|
||||
over stream-read1 dup starts-2?
|
||||
[ swap 6 shift swap BIN: 111111 bitand bitor ]
|
||||
[ 2drop replacement-char ] if ;
|
||||
|
||||
: begin-utf8 ( buf byte -- buf ch state )
|
||||
: double ( stream byte -- stream char )
|
||||
BIN: 11111 bitand append-nums ;
|
||||
|
||||
: triple ( stream byte -- stream char )
|
||||
BIN: 1111 bitand append-nums append-nums ;
|
||||
|
||||
: quad ( stream byte -- stream char )
|
||||
BIN: 111 bitand append-nums append-nums append-nums ;
|
||||
|
||||
: begin-utf8 ( stream byte -- stream char )
|
||||
{
|
||||
{ [ dup -7 shift zero? ] [ push-decoded ] }
|
||||
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
|
||||
{ [ t ] [ drop push-replacement ] }
|
||||
{ [ dup -7 shift zero? ] [ ] }
|
||||
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
|
||||
{ [ t ] [ drop replacement-char ] }
|
||||
} cond ;
|
||||
|
||||
: end-multibyte ( buf byte ch -- buf ch state )
|
||||
f append-nums [ push-decoded ] unless* ;
|
||||
: decode-utf8 ( stream -- char/f )
|
||||
dup stream-read1 dup [ begin-utf8 ] when nip ;
|
||||
|
||||
: decode-utf8-step ( buf byte ch state -- buf ch state )
|
||||
{
|
||||
{ begin [ drop begin-utf8 ] }
|
||||
{ double [ end-multibyte ] }
|
||||
{ triple [ triple2 append-nums ] }
|
||||
{ triple2 [ end-multibyte ] }
|
||||
{ quad [ quad2 append-nums ] }
|
||||
{ quad2 [ quad3 append-nums ] }
|
||||
{ quad3 [ end-multibyte ] }
|
||||
} case ;
|
||||
|
||||
: unpack-state ( encoding -- ch state )
|
||||
{ utf8-ch utf8-state } get-slots ;
|
||||
|
||||
: pack-state ( ch state encoding -- )
|
||||
{ set-utf8-ch set-utf8-state } set-slots ;
|
||||
|
||||
M: utf8 decode-step ( buf char encoding -- )
|
||||
[ unpack-state decode-utf8-step ] keep pack-state drop ;
|
||||
|
||||
M: utf8 init-decoder nip begin over set-utf8-state ;
|
||||
M: utf8 decode-char
|
||||
drop decode-utf8 ;
|
||||
|
||||
! Encoding UTF-8
|
||||
|
||||
: encoded ( char -- )
|
||||
BIN: 111111 bitand BIN: 10000000 bitor write1 ;
|
||||
: encoded ( stream char -- )
|
||||
BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
|
||||
|
||||
: char>utf8 ( char -- )
|
||||
: char>utf8 ( stream char -- )
|
||||
{
|
||||
{ [ dup -7 shift zero? ] [ write1 ] }
|
||||
{ [ dup -7 shift zero? ] [ swap stream-write1 ] }
|
||||
{ [ dup -11 shift zero? ] [
|
||||
dup -6 shift BIN: 11000000 bitor write1
|
||||
2dup -6 shift BIN: 11000000 bitor swap stream-write1
|
||||
encoded
|
||||
] }
|
||||
{ [ dup -16 shift zero? ] [
|
||||
dup -12 shift BIN: 11100000 bitor write1
|
||||
dup -6 shift encoded
|
||||
2dup -12 shift BIN: 11100000 bitor swap stream-write1
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
{ [ t ] [
|
||||
dup -18 shift BIN: 11110000 bitor write1
|
||||
dup -12 shift encoded
|
||||
dup -6 shift encoded
|
||||
2dup -18 shift BIN: 11110000 bitor swap stream-write1
|
||||
2dup -12 shift encoded
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
M: utf8 stream-write-encoded
|
||||
! For efficiency, this should be modified to avoid variable reads
|
||||
drop [ [ char>utf8 ] each ] with-stream* ;
|
||||
M: utf8 encode-char
|
||||
drop swap char>utf8 ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation"
|
|||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path+ }
|
||||
{ $subsection append-path }
|
||||
"Pathnames relative to Factor's install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
|
|
@ -54,9 +54,7 @@ ARTICLE: "fs-meta" "File meta-data"
|
|||
{ $subsection file-info }
|
||||
{ $subsection link-info }
|
||||
{ $subsection exists? }
|
||||
{ $subsection directory? }
|
||||
! { $subsection file-modified }
|
||||
{ $subsection stat } ;
|
||||
{ $subsection directory? } ;
|
||||
|
||||
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
||||
"Operations for deleting and copying files come in two forms:"
|
||||
|
|
@ -216,15 +214,7 @@ HELP: with-directory
|
|||
{ $description "Changes the current working directory for the duration of a quotation's execution." }
|
||||
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
|
||||
|
||||
HELP: stat ( path -- directory? permissions length modified )
|
||||
{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
|
||||
{ $description
|
||||
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
|
||||
} ;
|
||||
|
||||
{ stat exists? directory? } related-words
|
||||
|
||||
HELP: path+
|
||||
HELP: append-path
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
{ $description "Concatenates two pathnames." } ;
|
||||
|
||||
|
|
@ -273,7 +263,7 @@ HELP: normalize-directory
|
|||
|
||||
HELP: normalize-pathname
|
||||
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
||||
{ $description "Called by the " { $link stat } " word, and possibly " { $link <file-reader> } " and " { $link <file-writer> } ", to prepare a pathname before passing it to underlying code." } ;
|
||||
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
|
||||
|
||||
HELP: <pathname> ( str -- pathname )
|
||||
{ $values { "str" "a pathname string" } { "pathname" pathname } }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,10 @@
|
|||
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
|
||||
[ t ] [ "blahblah" temp-file directory? ] unit-test
|
||||
|
||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||
|
|
@ -123,3 +128,19 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
|
|||
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
|
||||
|
||||
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
|
||||
|
||||
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] 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
|
||||
|
|
|
|||
|
|
@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- )
|
|||
: left-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] left-trim ;
|
||||
|
||||
: path+ ( str1 str2 -- str )
|
||||
: append-path ( str1 str2 -- str )
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
swap append-path ; inline
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
|
|
@ -45,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 {
|
||||
|
|
@ -83,18 +83,11 @@ SYMBOL: +socket+
|
|||
SYMBOL: +unknown+
|
||||
|
||||
! File metadata
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
: exists? ( path -- ? )
|
||||
normalize-pathname (exists?) ;
|
||||
|
||||
! : file-length ( path -- n ) stat drop 2nip ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
! : file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) stat 3drop ;
|
||||
: directory? ( path -- ? )
|
||||
file-info file-info-type +directory+ = ;
|
||||
|
||||
! Current working directory
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
|
@ -123,7 +116,7 @@ HOOK: make-directory io-backend ( path -- )
|
|||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
[ tuck append-path directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
|
|
@ -131,7 +124,7 @@ HOOK: make-directory io-backend ( path -- )
|
|||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: directory* ( path -- seq )
|
||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
||||
dup directory [ first2 >r append-path r> 2array ] with map ;
|
||||
|
||||
! Touching files
|
||||
HOOK: touch-file io-backend ( path -- )
|
||||
|
|
@ -150,7 +143,7 @@ HOOK: delete-directory io-backend ( path -- )
|
|||
: delete-tree ( path -- )
|
||||
dup directory? (delete-tree) ;
|
||||
|
||||
: to-directory over file-name path+ ;
|
||||
: to-directory over file-name append-path ;
|
||||
|
||||
! Moving and renaming files
|
||||
HOOK: move-file io-backend ( from to -- )
|
||||
|
|
@ -183,7 +176,7 @@ DEFER: copy-tree-into
|
|||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
>r dup directory swap r> [
|
||||
>r swap first path+ r> copy-tree-into
|
||||
>r swap first append-path r> copy-tree-into
|
||||
] 2curry each
|
||||
] [
|
||||
copy-file
|
||||
|
|
@ -197,8 +190,8 @@ DEFER: copy-tree-into
|
|||
|
||||
! Special paths
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
"resource-path" get [ image parent-directory ] unless*
|
||||
prepend-path ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
|
|
@ -220,10 +213,7 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
dupd [ file-info file-info-size read ] with-file-reader ;
|
||||
|
||||
! : file-contents ( path encoding -- str )
|
||||
! dupd [ file-length read ] with-file-reader ;
|
||||
<file-reader> contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
|
@ -243,7 +233,7 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
||||
: temp-file ( name -- path ) temp-directory prepend-path ;
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables generic kernel math namespaces sequences strings
|
||||
continuations assocs io.styles sbufs ;
|
||||
USING: hashtables generic kernel math namespaces sequences
|
||||
continuations assocs io.styles ;
|
||||
IN: io
|
||||
|
||||
GENERIC: stream-readln ( stream -- str )
|
||||
|
|
@ -88,4 +88,6 @@ SYMBOL: stderr
|
|||
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
|
||||
|
||||
: contents ( stream -- str )
|
||||
2048 <sbuf> [ stream-copy ] keep >string ;
|
||||
[
|
||||
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
|
||||
] with-stream ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
|
||||
sequences io namespaces ;
|
||||
sequences io namespaces io.encodings.private ;
|
||||
IN: io.streams.byte-array
|
||||
|
||||
: <byte-writer> ( encoding -- stream )
|
||||
|
|
@ -7,7 +7,7 @@ IN: io.streams.byte-array
|
|||
|
||||
: with-byte-writer ( encoding quot -- byte-array )
|
||||
>r <byte-writer> r> [ stdio get ] compose with-stream*
|
||||
>byte-array ; inline
|
||||
dup encoder? [ encoder-stream ] when >byte-array ; inline
|
||||
|
||||
: <byte-reader> ( byte-array encoding -- stream )
|
||||
>r >byte-vector dup reverse-here r> <decoder> ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io io.files threads
|
||||
strings byte-arrays io.streams.lines io.streams.plain ;
|
||||
strings byte-arrays io.streams.plain ;
|
||||
IN: io.streams.c
|
||||
|
||||
ARTICLE: "io.streams.c" "ANSI C streams"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.string
|
||||
USING: io kernel math namespaces sequences sbufs strings
|
||||
generic splitting growable continuations io.streams.plain
|
||||
io.encodings ;
|
||||
io.encodings io.encodings.private ;
|
||||
IN: io.streams.string
|
||||
|
||||
M: growable dispose drop ;
|
||||
|
||||
|
|
@ -49,8 +49,11 @@ M: growable stream-read
|
|||
M: growable stream-read-partial
|
||||
stream-read ;
|
||||
|
||||
TUPLE: null ;
|
||||
M: null decode-char drop stream-read1 ;
|
||||
|
||||
: <string-reader> ( str -- stream )
|
||||
>sbuf dup reverse-here f <decoder> ;
|
||||
>sbuf dup reverse-here null <decoder> ;
|
||||
|
||||
: with-string-reader ( str quot -- )
|
||||
>r <string-reader> r> with-stream ; inline
|
||||
|
|
|
|||
|
|
@ -429,7 +429,14 @@ $nl
|
|||
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
|
||||
|
||||
HELP: die
|
||||
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
|
||||
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
|
||||
{ $notes
|
||||
"The term FEP originates from the Lisp machines of old. According to the Jargon File,"
|
||||
$nl
|
||||
{ $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
|
||||
$nl
|
||||
{ $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
|
||||
} ;
|
||||
|
||||
HELP: (clone) ( obj -- newobj )
|
||||
{ $values { "obj" object } { "newobj" "a shallow copy" } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -24,20 +24,40 @@ IN: optimizer.specializers
|
|||
\ dispatch ,
|
||||
] [ ] make ;
|
||||
|
||||
: specializer-methods ( quot word -- default alist )
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
[ declare ] curry pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop add* ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration [ declare ] curry prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
dup { number } = [
|
||||
drop tag-specializer
|
||||
] [
|
||||
specializer-cases alist>quot
|
||||
] if ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
"method-generic" word-prop standard-generic?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup word-def swap "specializer" word-prop [
|
||||
dup { number } = [
|
||||
drop tag-specializer
|
||||
] [
|
||||
specializer-methods alist>quot
|
||||
] if
|
||||
] when* ;
|
||||
dup word-def swap {
|
||||
{ [ dup standard-method? ] [ specialize-method ] }
|
||||
{
|
||||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
sorting tuples compiler.units debugger vocabs vocabs.loader ;
|
||||
IN: parser.tests
|
||||
|
||||
[
|
||||
|
|
@ -397,35 +397,47 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
[
|
||||
"redefining-a-class-5" forget-source
|
||||
"redefining-a-class-6" forget-source
|
||||
"redefining-a-class-7" forget-source
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests M: f foo ;"
|
||||
<string-reader> "redefining-a-class-6" parse-stream drop
|
||||
] unit-test
|
||||
2 [
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests M: f foo ;"
|
||||
<string-reader> "redefining-a-class-6" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
|
||||
] times
|
||||
|
||||
[ "resource:core/parser/test/assert-depth.factor" run-file ]
|
||||
[ relative-overflow-stack { 1 2 3 } sequence= ]
|
||||
|
|
@ -447,3 +459,13 @@ must-fail-with
|
|||
<string-reader> "d-f-s-test" parse-stream drop
|
||||
] unit-test
|
||||
] times
|
||||
|
||||
[ ] [ "parser" reload ] unit-test
|
||||
|
||||
[ ] [
|
||||
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"USE: this-better-not-exist" eval
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -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,13 +212,7 @@ SYMBOL: in
|
|||
: set-in ( name -- )
|
||||
check-vocab-string dup in set create-vocab (use+) ;
|
||||
|
||||
: create-in ( string -- word )
|
||||
in get create dup set-word dup save-location ;
|
||||
|
||||
TUPLE: unexpected want got ;
|
||||
|
||||
: unexpected ( want got -- * )
|
||||
\ unexpected construct-boa throw ;
|
||||
ERROR: unexpected want got ;
|
||||
|
||||
PREDICATE: unexpected unexpected-eof
|
||||
unexpected-got not ;
|
||||
|
|
@ -238,8 +229,15 @@ PREDICATE: unexpected unexpected-eof
|
|||
: parse-tokens ( end -- seq )
|
||||
100 <vector> swap (parse-tokens) >array ;
|
||||
|
||||
: create-in ( string -- word )
|
||||
in get create dup set-word dup save-location ;
|
||||
|
||||
: CREATE ( -- word ) scan create-in ;
|
||||
|
||||
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
||||
|
||||
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
|
||||
|
||||
: create-class-in ( word -- word )
|
||||
in get create
|
||||
dup save-class-location
|
||||
|
|
@ -284,10 +282,13 @@ M: no-word summary
|
|||
] ?if
|
||||
] when ;
|
||||
|
||||
TUPLE: staging-violation word ;
|
||||
: create-method-in ( class generic -- method )
|
||||
create-method f set-word dup save-location ;
|
||||
|
||||
: staging-violation ( word -- * )
|
||||
\ staging-violation construct-boa throw ;
|
||||
: CREATE-METHOD ( -- method )
|
||||
scan-word bootstrap-word scan-word create-method-in ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
||||
M: staging-violation summary
|
||||
drop
|
||||
|
|
@ -342,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 ;
|
||||
|
|
@ -355,7 +354,9 @@ TUPLE: bad-number ;
|
|||
: parse-definition ( -- quot )
|
||||
\ ; parse-until >quotation ;
|
||||
|
||||
: (:) CREATE dup reset-generic parse-definition ;
|
||||
: (:) CREATE-WORD parse-definition ;
|
||||
|
||||
: (M:) CREATE-METHOD parse-definition ;
|
||||
|
||||
GENERIC: expected>string ( obj -- str )
|
||||
|
||||
|
|
@ -466,7 +467,15 @@ SYMBOL: interactive-vocabs
|
|||
: smudged-usage ( -- usages referenced removed )
|
||||
removed-definitions filter-moved keys [
|
||||
outside-usages
|
||||
[ empty? swap pathname? or not ] assoc-subset
|
||||
[
|
||||
empty? [ drop f ] [
|
||||
{
|
||||
{ [ dup pathname? ] [ f ] }
|
||||
{ [ dup method-body? ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
} cond nip
|
||||
] if
|
||||
] assoc-subset
|
||||
dup values concat prune swap keys
|
||||
] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -317,3 +317,15 @@ unit-test
|
|||
[ ] [ 1 \ + curry unparse drop ] unit-test
|
||||
|
||||
[ ] [ 1 \ + compose unparse drop ] unit-test
|
||||
|
||||
GENERIC: generic-see-test-with-f ( obj -- obj )
|
||||
|
||||
M: f generic-see-test-with-f ;
|
||||
|
||||
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
|
||||
[ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
|
||||
[ \ f \ generic-see-test-with-f method see ] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -172,13 +172,13 @@ M: hook-generic synopsis*
|
|||
stack-effect. ;
|
||||
|
||||
M: method-spec synopsis*
|
||||
dup definer. [ pprint-word ] each ;
|
||||
first2 method synopsis* ;
|
||||
|
||||
M: method-body synopsis*
|
||||
dup dup
|
||||
definer.
|
||||
"method-class" word-prop pprint*
|
||||
"method-generic" word-prop pprint* ;
|
||||
"method-class" word-prop pprint-word
|
||||
"method-generic" word-prop pprint-word ;
|
||||
|
||||
M: mixin-instance synopsis*
|
||||
dup definer.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -299,6 +293,8 @@ M: immutable-sequence clone-like like ;
|
|||
|
||||
: append ( seq1 seq2 -- newseq ) over (append) ;
|
||||
|
||||
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
|
||||
|
||||
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
|
||||
|
||||
: change-nth ( i seq quot -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -10,14 +10,12 @@ TUPLE: slot-spec type name offset reader writer ;
|
|||
C: <slot-spec> slot-spec
|
||||
|
||||
: define-typecheck ( class generic quot -- )
|
||||
over define-simple-generic -rot define-method ;
|
||||
over define-simple-generic
|
||||
>r create-method r> define ;
|
||||
|
||||
: 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 ,
|
||||
|
|
@ -25,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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ IN: bootstrap.syntax
|
|||
"parsing" [ word t "parsing" set-word-prop ] define-syntax
|
||||
|
||||
"SYMBOL:" [
|
||||
CREATE dup reset-generic define-symbol
|
||||
CREATE-WORD define-symbol
|
||||
] define-syntax
|
||||
|
||||
"DEFER:" [
|
||||
|
|
@ -111,31 +111,26 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
"GENERIC:" [
|
||||
CREATE dup reset-word
|
||||
define-simple-generic
|
||||
CREATE-GENERIC define-simple-generic
|
||||
] define-syntax
|
||||
|
||||
"GENERIC#" [
|
||||
CREATE dup reset-word
|
||||
CREATE-GENERIC
|
||||
scan-word <standard-combination> define-generic
|
||||
] define-syntax
|
||||
|
||||
"MATH:" [
|
||||
CREATE dup reset-word
|
||||
CREATE-GENERIC
|
||||
T{ math-combination } define-generic
|
||||
] define-syntax
|
||||
|
||||
"HOOK:" [
|
||||
CREATE dup reset-word scan-word
|
||||
CREATE-GENERIC scan-word
|
||||
<hook-combination> define-generic
|
||||
] define-syntax
|
||||
|
||||
"M:" [
|
||||
f set-word
|
||||
location >r
|
||||
scan-word bootstrap-word scan-word
|
||||
[ parse-definition -rot define-method ] 2keep
|
||||
2array r> remember-definition
|
||||
(M:) define
|
||||
] define-syntax
|
||||
|
||||
"UNION:" [
|
||||
|
|
@ -163,11 +158,17 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
"C:" [
|
||||
CREATE dup reset-generic
|
||||
CREATE-WORD
|
||||
scan-word dup check-tuple
|
||||
[ construct-boa ] curry define-inline
|
||||
] define-syntax
|
||||
|
||||
"ERROR:" [
|
||||
CREATE-CLASS dup ";" parse-tokens define-tuple-class
|
||||
dup save-location
|
||||
dup [ construct-boa throw ] curry define
|
||||
] define-syntax
|
||||
|
||||
"FORGET:" [
|
||||
scan-word
|
||||
dup parsing? [ V{ } clone swap execute first ] when
|
||||
|
|
|
|||
|
|
@ -14,3 +14,5 @@ yield
|
|||
[ 3 ] [
|
||||
[ 3 swap resume-with ] "Test suspend" suspend
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f get-global ] unit-test
|
||||
|
|
|
|||
|
|
@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
|
|||
|
||||
: threads 41 getenv ;
|
||||
|
||||
threads global [ H{ } assoc-like ] change-at
|
||||
|
||||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
: thread-registered? ( thread -- ? )
|
||||
|
|
|
|||
|
|
@ -3,18 +3,28 @@ 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:"
|
||||
{ $subsection POSTPONE: C: }
|
||||
"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" } } "." ;
|
||||
"Examples of constructors:"
|
||||
{ $code
|
||||
"TUPLE: color red green blue alpha ;"
|
||||
""
|
||||
"C: <rgba> rgba"
|
||||
": <rgba> color construct-boa ; ! identical to above"
|
||||
""
|
||||
": <rgb> f <rgba> ;"
|
||||
""
|
||||
": <color> construct-empty ;"
|
||||
": <color> f f f f <rgba> ; ! identical to above"
|
||||
} ;
|
||||
|
||||
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 }
|
||||
|
|
@ -32,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 }"
|
||||
} ;
|
||||
|
||||
|
|
@ -42,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 ;" }
|
||||
"This defines a class word named " { $snippet "person" } ", along with a predicate " { $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"
|
||||
|
||||
|
|
|
|||
|
|
@ -236,7 +236,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -43,8 +43,6 @@ HELP: find-vocab-root
|
|||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
||||
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
|
||||
|
||||
{ vocab-root find-vocab-root } related-words
|
||||
|
||||
HELP: no-vocab
|
||||
{ $values { "name" "a vocabulary name" } }
|
||||
{ $description "Throws a " { $link no-vocab } "." }
|
||||
|
|
|
|||
|
|
@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ;
|
|||
] unit-test
|
||||
|
||||
[ T{ vocab-link f "vocabs.loader.test" } ]
|
||||
[ "vocabs.loader.test" f >vocab-link ] unit-test
|
||||
[ "vocabs.loader.test" >vocab-link ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
|
||||
[ "kernel" >vocab-link "kernel" vocab = ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"kernel" vocab-files
|
||||
"kernel" vocab vocab-files
|
||||
"kernel" f <vocab-link> vocab-files
|
||||
"kernel" <vocab-link> vocab-files
|
||||
3array all-equal?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ IN: vocabs.loader.tests
|
|||
[ { 3 3 3 } ] [
|
||||
"vocabs.loader.test.2" run
|
||||
"vocabs.loader.test.2" vocab run
|
||||
"vocabs.loader.test.2" f <vocab-link> run
|
||||
"vocabs.loader.test.2" <vocab-link> run
|
||||
3array
|
||||
] unit-test
|
||||
|
||||
|
|
@ -78,6 +78,8 @@ IN: vocabs.loader.tests
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"vocabs.loader.test.b" vocab-files
|
||||
|
|
@ -113,11 +115,18 @@ IN: vocabs.loader.tests
|
|||
[ 3 ] [ "count-me" get-global ] unit-test
|
||||
|
||||
[ { "resource:core/kernel/kernel.factor" 1 } ]
|
||||
[ "kernel" f <vocab-link> where ] unit-test
|
||||
[ "kernel" <vocab-link> where ] unit-test
|
||||
|
||||
[ { "resource:core/kernel/kernel.factor" 1 } ]
|
||||
[ "kernel" vocab where ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"vocabs.loader.test.c" forget-vocab
|
||||
"vocabs.loader.test.d" forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "vocabs.loader.test.d" require ] [ :1 ] recover
|
||||
"vocabs.loader.test.d" vocab-source-loaded?
|
||||
|
|
@ -127,7 +136,7 @@ IN: vocabs.loader.tests
|
|||
[
|
||||
{ "2" "a" "b" "d" "e" "f" }
|
||||
[
|
||||
"vocabs.loader.test." swap append forget-vocab
|
||||
"vocabs.loader.test." prepend forget-vocab
|
||||
] each
|
||||
] with-compilation-unit ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,30 +23,30 @@ V{
|
|||
[ >r dup peek r> append add ] when*
|
||||
"/" join ;
|
||||
|
||||
: vocab-path+ ( vocab path -- newpath )
|
||||
swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
|
||||
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup ".factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup "-docs.factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-dir? ( root name -- ? )
|
||||
over [
|
||||
".factor" vocab-dir+ path+ resource-exists?
|
||||
".factor" vocab-dir+ append-path resource-exists?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
SYMBOL: root-cache
|
||||
|
||||
H{ } clone root-cache set-global
|
||||
|
||||
: find-vocab-root ( vocab -- path/f )
|
||||
vocab-roots get swap [ vocab-dir? ] curry find nip ;
|
||||
vocab-name root-cache get [
|
||||
vocab-roots get swap [ vocab-dir? ] curry find nip
|
||||
] cache ;
|
||||
|
||||
M: string vocab-root
|
||||
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
|
||||
: vocab-append-path ( vocab path -- newpath )
|
||||
swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
|
||||
|
||||
M: vocab-link vocab-root
|
||||
vocab-link-root ;
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup ".factor" vocab-dir+ vocab-append-path ;
|
||||
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup "-docs.factor" vocab-dir+ vocab-append-path ;
|
||||
|
||||
SYMBOL: load-help?
|
||||
|
||||
|
|
@ -56,7 +56,7 @@ SYMBOL: load-help?
|
|||
|
||||
: load-source ( vocab -- )
|
||||
[ source-wasn't-loaded ] keep
|
||||
[ vocab-source-path bootstrap-file ] keep
|
||||
[ vocab-source-path [ bootstrap-file ] when* ] keep
|
||||
source-was-loaded ;
|
||||
|
||||
: docs-were-loaded t swap set-vocab-docs-loaded? ;
|
||||
|
|
@ -66,24 +66,13 @@ SYMBOL: load-help?
|
|||
: load-docs ( vocab -- )
|
||||
load-help? get [
|
||||
[ docs-weren't-loaded ] keep
|
||||
[ vocab-docs-path ?run-file ] keep
|
||||
[ vocab-docs-path [ ?run-file ] when* ] keep
|
||||
docs-were-loaded
|
||||
] [ drop ] if ;
|
||||
|
||||
: create-vocab-with-root ( vocab-link -- vocab )
|
||||
dup vocab-name create-vocab
|
||||
swap vocab-root over set-vocab-root ;
|
||||
|
||||
: reload ( name -- )
|
||||
[
|
||||
f >vocab-link
|
||||
dup vocab-root [
|
||||
dup vocab-source-path resource-exists? [
|
||||
create-vocab-with-root
|
||||
dup load-source
|
||||
load-docs
|
||||
] [ no-vocab ] if
|
||||
] [ no-vocab ] if
|
||||
dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
|
||||
] with-compiler-errors ;
|
||||
|
||||
: require ( vocab -- )
|
||||
|
|
@ -100,33 +89,37 @@ SYMBOL: load-help?
|
|||
|
||||
SYMBOL: blacklist
|
||||
|
||||
GENERIC: (load-vocab) ( name -- vocab )
|
||||
|
||||
: add-to-blacklist ( error vocab -- )
|
||||
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
|
||||
|
||||
GENERIC: (load-vocab) ( name -- )
|
||||
|
||||
M: vocab (load-vocab)
|
||||
[
|
||||
dup vocab-root [
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
] when
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
drop
|
||||
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
|
||||
|
||||
M: string (load-vocab)
|
||||
[ ".private" ?tail drop reload ] keep vocab ;
|
||||
|
||||
M: vocab-link (load-vocab)
|
||||
vocab-name (load-vocab) ;
|
||||
vocab-name create-vocab (load-vocab) ;
|
||||
|
||||
M: string (load-vocab)
|
||||
create-vocab (load-vocab) ;
|
||||
|
||||
[
|
||||
dup vocab-name blacklist get at* [
|
||||
rethrow
|
||||
] [
|
||||
drop
|
||||
[ dup vocab swap or (load-vocab) ] with-compiler-errors
|
||||
] if
|
||||
|
||||
[
|
||||
dup vocab-name blacklist get at* [
|
||||
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
|
||||
|
||||
: vocab-where ( vocab -- loc )
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ $nl
|
|||
{ $subsection vocab }
|
||||
"Accessors for various vocabulary attributes:"
|
||||
{ $subsection vocab-name }
|
||||
{ $subsection vocab-root }
|
||||
{ $subsection vocab-main }
|
||||
{ $subsection vocab-help }
|
||||
"Looking up existing vocabularies and creating new vocabularies:"
|
||||
|
|
@ -50,10 +49,6 @@ HELP: vocab-name
|
|||
{ $values { "vocab" "a vocabulary specifier" } { "name" string } }
|
||||
{ $description "Outputs the name of a vocabulary." } ;
|
||||
|
||||
HELP: vocab-root
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
|
||||
{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
|
||||
|
||||
HELP: vocab-words
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
|
||||
{ $description "Outputs the words defined in a vocabulary." } ;
|
||||
|
|
@ -101,11 +96,11 @@ HELP: child-vocabs
|
|||
} ;
|
||||
|
||||
HELP: vocab-link
|
||||
{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
|
||||
{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
|
||||
$nl
|
||||
"Vocabulary links are created by calling " { $link >vocab-link } "."
|
||||
} ;
|
||||
|
||||
HELP: >vocab-link
|
||||
{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
|
||||
{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;
|
||||
|
|
|
|||
|
|
@ -7,16 +7,15 @@ IN: vocabs
|
|||
SYMBOL: dictionary
|
||||
|
||||
TUPLE: vocab
|
||||
name root
|
||||
words
|
||||
name words
|
||||
main help
|
||||
source-loaded? docs-loaded? ;
|
||||
|
||||
M: vocab equal? 2drop f ;
|
||||
|
||||
: <vocab> ( name -- vocab )
|
||||
H{ } clone t
|
||||
{ set-vocab-name set-vocab-words set-vocab-source-loaded? }
|
||||
H{ } clone
|
||||
{ set-vocab-name set-vocab-words }
|
||||
\ vocab construct ;
|
||||
|
||||
GENERIC: vocab ( vocab-spec -- vocab )
|
||||
|
|
@ -60,9 +59,12 @@ M: f vocab-help ;
|
|||
: create-vocab ( name -- vocab )
|
||||
dictionary get [ <vocab> ] cache ;
|
||||
|
||||
SYMBOL: load-vocab-hook
|
||||
ERROR: no-vocab name ;
|
||||
|
||||
: load-vocab ( name -- vocab ) load-vocab-hook get call ;
|
||||
SYMBOL: load-vocab-hook ! ( name -- )
|
||||
|
||||
: load-vocab ( name -- vocab )
|
||||
dup load-vocab-hook get call vocab ;
|
||||
|
||||
: vocabs ( -- seq )
|
||||
dictionary get keys natural-sort ;
|
||||
|
|
@ -85,10 +87,10 @@ SYMBOL: load-vocab-hook
|
|||
: child-vocabs ( vocab -- seq )
|
||||
vocab-name vocabs [ child-vocab? ] with subset ;
|
||||
|
||||
TUPLE: vocab-link name root ;
|
||||
TUPLE: vocab-link name ;
|
||||
|
||||
: <vocab-link> ( name root -- vocab-link )
|
||||
[ dup vocab-root ] unless* vocab-link construct-boa ;
|
||||
: <vocab-link> ( name -- vocab-link )
|
||||
vocab-link construct-boa ;
|
||||
|
||||
M: vocab-link equal?
|
||||
over vocab-link?
|
||||
|
|
@ -99,24 +101,16 @@ M: vocab-link hashcode*
|
|||
|
||||
M: vocab-link vocab-name vocab-link-name ;
|
||||
|
||||
GENERIC# >vocab-link 1 ( name root -- vocab )
|
||||
|
||||
M: vocab >vocab-link drop ;
|
||||
|
||||
M: vocab-link >vocab-link drop ;
|
||||
|
||||
M: string >vocab-link
|
||||
over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
|
||||
|
||||
UNION: vocab-spec vocab vocab-link ;
|
||||
|
||||
GENERIC: >vocab-link ( name -- vocab )
|
||||
|
||||
M: vocab-spec >vocab-link ;
|
||||
|
||||
M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
|
||||
|
||||
: forget-vocab ( vocab -- )
|
||||
dup words forget-all
|
||||
vocab-name dictionary get delete-at ;
|
||||
|
||||
M: vocab-spec forget* forget-vocab ;
|
||||
|
||||
TUPLE: no-vocab name ;
|
||||
|
||||
: no-vocab ( name -- * )
|
||||
vocab-name \ no-vocab construct-boa throw ;
|
||||
|
|
|
|||
|
|
@ -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 ] = ;
|
||||
|
|
@ -68,7 +66,7 @@ SYMBOL: bootstrapping?
|
|||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method-def" word-prop ] [ t ] }
|
||||
{ [ dup "method-generic" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
@ -169,7 +167,12 @@ SYMBOL: changed-words
|
|||
"declared-effect" "constructor-quot" "delimiter"
|
||||
} reset-props ;
|
||||
|
||||
GENERIC: subwords ( word -- seq )
|
||||
|
||||
M: word subwords drop f ;
|
||||
|
||||
: reset-generic ( word -- )
|
||||
dup subwords [ forget ] each
|
||||
dup reset-word
|
||||
{ "methods" "combination" "default-method" } reset-props ;
|
||||
|
||||
|
|
@ -184,12 +187,11 @@ SYMBOL: changed-words
|
|||
[ ] [ 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
|
||||
|
|
|
|||
|
|
@ -135,18 +135,18 @@ SYMBOL: end
|
|||
GENERIC: >ber ( obj -- byte-array )
|
||||
M: fixnum >ber ( n -- byte-array )
|
||||
>128-ber dup length 2 swap 2array
|
||||
"cc" pack-native swap append ;
|
||||
"cc" pack-native prepend ;
|
||||
|
||||
: >ber-enumerated ( n -- byte-array )
|
||||
>128-ber >byte-array dup length 10 swap 2array
|
||||
"CC" pack-native swap append ;
|
||||
"CC" pack-native prepend ;
|
||||
|
||||
: >ber-length-encoding ( n -- byte-array )
|
||||
dup 127 <= [
|
||||
1array "C" pack-be
|
||||
] [
|
||||
1array "I" pack-be 0 swap remove dup length
|
||||
HEX: 80 + 1array "C" pack-be swap append
|
||||
HEX: 80 + 1array "C" pack-be prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array )
|
|||
dup 126 > [
|
||||
"range error in bignum" throw
|
||||
] [
|
||||
2 swap 2array "CC" pack-native swap append
|
||||
2 swap 2array "CC" pack-native prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: assocs kernel vectors sequences namespaces ;
|
||||
USING: arrays assocs kernel vectors sequences namespaces
|
||||
random math.parser ;
|
||||
IN: assocs.lib
|
||||
|
||||
: >set ( seq -- hash )
|
||||
|
|
@ -35,3 +36,13 @@ IN: assocs.lib
|
|||
[ with each ] curry assoc-each ; inline
|
||||
|
||||
: insert ( value variable -- ) namespace insert-at ;
|
||||
|
||||
: 2seq>assoc ( keys values exemplar -- assoc )
|
||||
>r 2array flip r> assoc-like ;
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
>r 256 random-bits >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
||||
: set-at-unique ( value assoc -- key )
|
||||
dup generate-key [ swap set-at ] keep ;
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
|||
|
||||
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
|
||||
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
||||
|
||||
: wrap-line ( a-line-z -- za-line-za )
|
||||
dup peek 1array swap dup first 1array append append ;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
|||
>r keys r> define-slots ;
|
||||
|
||||
: define-setters ( classname slots -- )
|
||||
>r "with-" swap append r>
|
||||
>r "with-" prepend r>
|
||||
dup values [setters]
|
||||
>r keys r> define-slots ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,11 +9,10 @@ IN: bootstrap.help
|
|||
|
||||
t load-help? set-global
|
||||
|
||||
[ vocab ] load-vocab-hook [
|
||||
[ drop ] load-vocab-hook [
|
||||
vocabs
|
||||
[ vocab-root ] subset
|
||||
[ vocab-source-loaded? ] subset
|
||||
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
|
||||
[ vocab-docs-loaded? not ] subset
|
||||
[ load-docs ] each
|
||||
] with-variable ;
|
||||
|
||||
load-help
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ bootstrap.image sequences io ;
|
|||
: download-image ( arch -- )
|
||||
boot-image-name dup need-new-image? [
|
||||
"Downloading " write dup write "..." print
|
||||
url swap append download
|
||||
url prepend download
|
||||
] [
|
||||
"Boot image up to date" print
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
USING: vocabs.loader sequences system
|
||||
random random.mersenne-twister combinators init
|
||||
namespaces ;
|
||||
|
||||
"random.mersenne-twister" require
|
||||
|
||||
{
|
||||
{ [ windows? ] [ "random.windows" require ] }
|
||||
{ [ unix? ] [ "random.unix" require ] }
|
||||
} cond
|
||||
|
||||
[ millis <mersenne-twister> random-generator set-global ]
|
||||
"generator.random" add-init-hook
|
||||
|
|
@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
|
|||
"tools.threads"
|
||||
"tools.vocabs"
|
||||
"tools.vocabs.browser"
|
||||
"tools.vocabs.monitor"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel vocabs vocabs.loader sequences system ;
|
||||
|
||||
{ "ui" "help" "tools" }
|
||||
[ "bootstrap." swap append vocab ] all? [
|
||||
[ "bootstrap." prepend vocab ] all? [
|
||||
"ui.tools" require
|
||||
|
||||
"ui.cocoa" vocab [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ vocabs vocabs.loader ;
|
|||
{ [ windows? ] [ "windows" ] }
|
||||
{ [ unix? ] [ "x11" ] }
|
||||
} cond
|
||||
] unless* "ui." swap append require
|
||||
] unless* "ui." prepend require
|
||||
|
||||
"ui.freetype" require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
|
|||
|
||||
IN: builder.benchmark
|
||||
|
||||
: passing-benchmarks ( table -- table )
|
||||
[ second first2 number? swap number? and ] subset ;
|
||||
! : passing-benchmarks ( table -- table )
|
||||
! [ second first2 number? swap number? and ] subset ;
|
||||
|
||||
: simplify-table ( table -- table ) [ first2 second 2array ] map ;
|
||||
: passing-benchmarks ( table -- table ) [ second number? ] subset ;
|
||||
|
||||
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
|
||||
|
||||
: benchmark-difference ( old-table benchmark-result -- result-diff )
|
||||
first2 >r
|
||||
|
|
@ -17,7 +19,7 @@ IN: builder.benchmark
|
|||
2array ;
|
||||
|
||||
: compare-tables ( old new -- table )
|
||||
[ passing-benchmarks simplify-table ] 2apply
|
||||
[ passing-benchmarks ] 2apply
|
||||
[ benchmark-difference ] with map ;
|
||||
|
||||
: benchmark-deltas ( -- table )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue