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

db4
Daniel Ehrenberg 2008-03-21 16:59:40 -04:00
commit 4cfd62c373
115 changed files with 1069 additions and 617 deletions

2
.gitignore vendored
View File

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

View File

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

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

@ -0,0 +1,157 @@
#include <stdio.h>
#if defined(__FreeBSD__)
#define BSD
#define FREEBSD
#define UNIX
#endif
#if defined(__NetBSD__)
#define BSD
#define NETBSD
#define UNIX
#endif
#if (__OpenBSD__)
#define BSD
#define OPENBSD
#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 <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);
}
int main() {
#ifdef FREEBSD
grovel(blkcnt_t);
grovel(blksize_t);
grovel(fflags_t);
#endif
#ifdef OPENBSD
openbsd_stat();
openbsd_types();
#endif
#ifdef UNIX
unix_types();
unix_constants();
#endif
return 0;
}

38
build-support/target Executable file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -8,7 +8,8 @@ $nl
"The main entry point to the optimizing compiler:" "The main entry point to the optimizing compiler:"
{ $subsection optimized-recompile-hook } { $subsection optimized-recompile-hook }
"Removing a word's optimized definition:" "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" ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:" "Factor is a fully compiled language implementation with two distinct compilers:"

View File

@ -9,7 +9,9 @@ $nl
$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:" "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 } { $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-definition }
{ $subsection remember-class } { $subsection remember-class }
"Forward reference checking (see " { $link "definition-checking" } "):" "Forward reference checking (see " { $link "definition-checking" } "):"

View File

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

View File

@ -75,9 +75,7 @@ SYMBOL: error-hook
: try ( quot -- ) : try ( quot -- )
[ error-hook get call ] recover ; [ error-hook get call ] recover ;
TUPLE: assert got expect ; ERROR: assert got expect ;
: assert ( got expect -- * ) \ assert construct-boa throw ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ; : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
@ -86,28 +84,22 @@ TUPLE: assert got expect ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ; 2dup [ length ] 2apply min tuck tail >r tail r> ;
TUPLE: relative-underflow stack ; ERROR: relative-underflow stack ;
: relative-underflow ( before after -- * )
trim-datastacks nip \ relative-underflow construct-boa throw ;
M: relative-underflow summary M: relative-underflow summary
drop "Too many items removed from data stack" ; drop "Too many items removed from data stack" ;
TUPLE: relative-overflow stack ; ERROR: relative-overflow stack ;
M: relative-overflow summary M: relative-overflow summary
drop "Superfluous items pushed to data stack" ; drop "Superfluous items pushed to data stack" ;
: relative-overflow ( before after -- * )
trim-datastacks drop \ relative-overflow construct-boa throw ;
: assert-depth ( quot -- ) : assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r> >r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn { 2dup [ length ] compare sgn {
{ -1 [ relative-underflow ] } { -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] } { 0 [ 2drop ] }
{ 1 [ relative-overflow ] } { 1 [ trim-datastacks drop relative-overflow ] }
} case ; inline } case ; inline
: expired-error. ( obj -- ) : expired-error. ( obj -- )
@ -210,13 +202,13 @@ M: no-method error.
M: no-math-method summary M: no-math-method summary
drop "No suitable arithmetic method" ; drop "No suitable arithmetic method" ;
M: check-closed summary M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ; drop "Attempt to perform I/O on closed stream" ;
M: check-method summary M: check-method summary
drop "Invalid parameters for create-method" ; drop "Invalid parameters for create-method" ;
M: check-tuple summary M: no-tuple-class summary
drop "Invalid class for define-constructor" ; drop "Invalid class for define-constructor" ;
M: no-cond summary M: no-cond summary
@ -254,7 +246,7 @@ M: no-compilation-unit error.
M: no-vocab summary M: no-vocab summary
drop "Vocabulary does not exist" ; drop "Vocabulary does not exist" ;
M: check-ptr summary M: bad-ptr summary
drop "Memory allocation failed" ; drop "Memory allocation failed" ;
M: double-free summary M: double-free summary

View File

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

View File

@ -85,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ; { $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find 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." } { $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 } "." { $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl $nl
@ -93,20 +93,20 @@ HELP: dlist-find
} ; } ;
HELP: dlist-contains? 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." } { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node-if* 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." } { $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)." } ; { $notes "This operation is O(n)." } ;
HELP: delete-node-if 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." } { $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)." } ; { $notes "This operation is O(n)." } ;
HELP: dlist-each 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." } ; { $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

View File

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

View File

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

View File

@ -126,7 +126,7 @@ HELP: method
{ method create-method POSTPONE: M: } related-words { method create-method POSTPONE: M: } related-words
HELP: <method> 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." } ; { $description "Creates a new method." } ;
HELP: methods HELP: methods
@ -143,7 +143,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ; { $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods 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." } { $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 ; $low-level-note ;

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

@ -15,7 +15,7 @@ HELP: no-math-method
HELP: math-method HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $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." } { $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 HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

View File

@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
dup empty? [ [ dip ] curry [ ] like ] unless dup empty? [ [ dip ] curry [ ] like ] unless
r> append ; r> append ;
TUPLE: no-math-method left right generic ; ERROR: no-math-method left right generic ;
: no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ;
: default-math-method ( generic -- quot ) : default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ; [ no-math-method ] curry [ ] like ;

View File

@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
TUPLE: no-method object generic ; ERROR: no-method object generic ;
: no-method ( object generic -- * )
\ no-method construct-boa throw ;
: error-method ( word -- quot ) : error-method ( word -- quot )
picker swap [ no-method ] curry append ; picker swap [ no-method ] curry append ;

View File

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

View File

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

View File

@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream"
{ $subsection <decoder> } { $subsection <decoder> }
{ $subsection <encoder-duplex> } ; { $subsection <encoder-duplex> } ;
HELP: <encoder> ( stream encoding -- newstream ) HELP: <encoder>
{ $values { "stream" "an output stream" } { $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" } { "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } } { "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" } "." } ; { $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" } { $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" } { "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } } { "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" } "." } ; { $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" } { $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" } { "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" } { "encoding" "an encoding descriptor" }
@ -51,12 +51,12 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
{ $subsection <encoder> } { $subsection <encoder> }
{ $subsection <decoder> } ; { $subsection <decoder> } ;
HELP: decode-char ( stream encoding -- char/f ) HELP: decode-char
{ $values { "stream" "an underlying input stream" } { $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } } { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ; { $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
HELP: encode-char ( char stream encoding -- ) HELP: encode-char
{ $values { "char" "a character" } { $values { "char" "a character" }
{ "stream" "an underlying output stream" } { "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } } { "encoding" "an encoding descriptor" } }

View File

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

View File

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

View File

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

View File

@ -28,15 +28,6 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing ! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test [ ] [ "\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 } { "It seems " CHAR: J }
@ -58,3 +49,12 @@ IN: io.tests
10 [ 65536 read drop ] times 10 [ 65536 read drop ] times
] with-file-reader ] with-file-reader
] unit-test ] 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

View File

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

View File

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

View File

@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ;
IN: mirrors IN: mirrors
ARTICLE: "mirrors" "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 }
{ $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 }
{ $subsection <enum> } { $subsection <enum> }
"Utility word used by developer tools which inspect objects:" "Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror } ; { $subsection make-mirror }
{ $see-also "slots" } ;
ABOUT: "mirrors" ABOUT: "mirrors"

View File

@ -224,7 +224,7 @@ HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } { $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)." } ; { $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 )" } } } { $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." } ; { $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;

View File

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

View File

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

View File

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

View File

@ -4,21 +4,86 @@ effects generic.standard tuples slots.private classes
strings math ; strings math ;
IN: slots 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" 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 $nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." { $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 $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." "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 } { $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." "The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
{ $subsection reader-word } { $subsection reader-word }
{ $subsection writer-word } { $subsection writer-word }
{ $subsection setter-word } { $subsection setter-word }
{ $subsection changer-word } { $subsection changer-word }
"Slot methods type check, then call unsafe primitives:" "Looking up a slot by name:"
{ $subsection slot } { $subsection slot-named }
{ $subsection set-slot } ; "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" ABOUT: "slots"
@ -58,8 +123,8 @@ HELP: reader-effect
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ; { $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader HELP: define-reader
{ $values { "class" class } { "spec" slot-spec } } { $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." } { $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ; $low-level-note ;
HELP: writer-effect HELP: writer-effect
@ -67,13 +132,13 @@ HELP: writer-effect
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ; { $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: define-writer 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" } "." } { $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ; $low-level-note ;
HELP: define-slot-methods HELP: define-slot-methods
{ $values { "class" class } { "spec" slot-spec } } { $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." } { $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
$low-level-note ; $low-level-note ;
HELP: define-accessors HELP: define-accessors

View File

@ -23,7 +23,7 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if [ drop ] [ 1array , \ declare , ] if
] [ ] make ; ] [ ] make ;
: slot-named ( string specs -- spec/f ) : slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ; [ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word ) : create-accessor ( name effect -- word )

View File

@ -1,4 +1,4 @@
USING: splitting tools.test ; USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail [ { 1 2 3 } 0 group ] must-fail
@ -56,3 +56,9 @@ unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" 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

View File

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

View File

@ -227,6 +227,9 @@ HELP: foldable
} }
"The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them." "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." } ; { $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ;
HELP: flushable HELP: flushable
@ -556,10 +559,17 @@ HELP: PREDICATE:
HELP: TUPLE: HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" } { $syntax "TUPLE: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } { $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 $nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; "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: HELP: C:
{ $syntax "C: constructor class" } { $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } } { $values { "constructor" "a new word to define" } { "class" tuple-class } }

View File

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

View File

@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ; generic.standard sequences definitions compiler.units ;
IN: tuples IN: tuples
ARTICLE: "tuple-constructors" "Constructors and slots" ARTICLE: "tuple-constructors" "Constructors"
"Tuples are created by calling one of a number of words:" "Tuples are created by calling one of two words:"
{ $subsection construct-empty } { $subsection construct-empty }
{ $subsection construct-boa } { $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>" } "." "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 $nl
"A shortcut for defining BOA constructors:" "A shortcut for defining BOA constructors:"
@ -19,18 +18,13 @@ $nl
"C: <rgba> rgba" "C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above" ": <rgba> color construct-boa ; ! identical to above"
"" ""
": <rgb>" ": <rgb> f <rgba> ;"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
": <rgb> f <rgba> ; ! identical to above"
"" ""
": <color> construct-empty ;" ": <color> construct-empty ;"
": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above" ": <color> f f f f <rgba> ; ! identical to above"
} } ;
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
ARTICLE: "tuple-delegation" "Delegation" ARTICLE: "tuple-delegation" "Tuple delegation"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown." "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 delegate }
{ $subsection set-delegate } { $subsection set-delegate }
@ -48,7 +42,7 @@ $nl
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set" "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
"{ 1 0 0 } <colored> \"my-shape\" set" "{ 1 0 0 } <colored> \"my-shape\" set"
"\"my-ellipse\" get \"my-shape\" get set-delegate" "\"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 }" "{ 0 0 }\n{ 1 0 0 }"
} ; } ;
@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
{ $subsection tuple>array } { $subsection tuple>array }
{ $subsection tuple-slots } { $subsection tuple-slots }
"Tuple classes can also be defined at run time:" "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" 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: } { $subsection POSTPONE: TUPLE: }
"An example:" "For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
{ $code "TUPLE: person name address phone ;" "C: <person> person" } $nl
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:" "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:"
{ $table { $subsection "accessors" }
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }
{ { $snippet "person-address" } { $snippet "set-person-address" } }
{ { $snippet "person-phone" } { $snippet "set-person-phone" } }
}
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" } { $subsection "tuple-constructors" }
"Further topics:" "Further topics:"
{ $subsection "tuple-delegation" } { $subsection "tuple-delegation" }
{ $subsection "tuple-introspection" } ; { $subsection "tuple-introspection" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples" ABOUT: "tuples"

View File

@ -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 "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 ! Hardcore unit tests
USE: threads USE: threads

View File

@ -89,11 +89,11 @@ PRIVATE>
2dup define-slots 2dup define-slots
define-accessors ; define-accessors ;
TUPLE: check-tuple class ; ERROR: no-tuple-class class ;
: check-tuple ( class -- ) : check-tuple ( class -- )
dup tuple-class? dup tuple-class?
[ drop ] [ \ check-tuple construct-boa throw ] if ; [ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- ) : define-tuple-class ( class slots -- )
2dup check-shape 2dup check-shape

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

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

View File

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

View File

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

View File

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

View File

Before

Width:  |  Height:  |  Size: 59 KiB

After

Width:  |  Height:  |  Size: 59 KiB

View File

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

View File

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

View File

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

View File

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

View File

@ -28,7 +28,7 @@ M: template-lexer skip-word
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ f skip ] } { [ t ] [ f skip ] }
} cond } cond
] change-column ; ] change-lexer-column ;
DEFER: <% delimiter DEFER: <% delimiter

View File

@ -1,5 +1,5 @@
USING: io.backend ; USING: io.backend ;
IN: io.files.unique.backend IN: io.files.unique.backend
HOOK: (make-unique-file) io-backend ( path -- stream ) HOOK: (make-unique-file) io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path ) HOOK: temporary-path io-backend ( -- path )

View File

@ -6,18 +6,16 @@ ARTICLE: "unique" "Making and using unique files"
"Files:" "Files:"
{ $subsection make-unique-file } { $subsection make-unique-file }
{ $subsection with-unique-file } { $subsection with-unique-file }
{ $subsection with-temporary-file }
"Directories:" "Directories:"
{ $subsection make-unique-directory } { $subsection make-unique-directory }
{ $subsection with-unique-directory } { $subsection with-unique-directory } ;
{ $subsection with-temporary-directory } ;
ABOUT: "unique" ABOUT: "unique"
HELP: make-unique-file ( prefix suffix -- path stream ) HELP: make-unique-file ( prefix suffix -- path )
{ $values { "prefix" "a string" } { "suffix" "a string" } { $values { "prefix" "a string" } { "suffix" "a string" }
{ "path" "a pathname string" } { "stream" "an output stream" } } { "path" "a pathname string" } }
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link <writer> } " stream." } { $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } { $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-file } ; { $see-also with-unique-file } ;
@ -27,24 +25,13 @@ HELP: make-unique-directory ( -- path )
{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } { $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-directory } ; { $see-also with-unique-directory } ;
HELP: with-unique-file ( quot -- path ) HELP: with-unique-file ( prefix suffix quot -- )
{ $values { "quot" "a quotation" } { "path" "a pathname string" } } { $values { "prefix" "a string" } { "suffix" "a string" }
{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." } { "quot" "a quotation" } }
{ $notes "The unique file will remain after calling this word." } { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
{ $see-also with-temporary-file } ; { $notes "The unique file will be deleted after calling this word." } ;
HELP: with-unique-directory ( quot -- path ) HELP: with-unique-directory ( quot -- )
{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." }
{ $notes "The directory will remain after calling this word." }
{ $see-also with-temporary-directory } ;
HELP: with-temporary-file ( quot -- )
{ $values { "quot" "a quotation" } } { $values { "quot" "a quotation" } }
{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." } { $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
{ $see-also with-unique-file } ; { $notes "The directory will be deleted after calling this word." } ;
HELP: with-temporary-directory ( quot -- )
{ $values { "quot" "a quotation" } }
{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." }
{ $see-also with-unique-directory } ;

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitfields combinators.lib math.parser USING: kernel math math.bitfields combinators.lib math.parser
random sequences sequences.lib continuations namespaces random sequences sequences.lib continuations namespaces
io.files io.backend io.nonblocking io arrays io.files io arrays io.files.unique.backend system
io.files.unique.backend system combinators vocabs.loader ; combinators vocabs.loader ;
IN: io.files.unique IN: io.files.unique
<PRIVATE <PRIVATE
@ -21,18 +21,15 @@ IN: io.files.unique
: unique-retries ( -- n ) 10 ; inline : unique-retries ( -- n ) 10 ; inline
PRIVATE> PRIVATE>
: make-unique-file ( prefix suffix -- path stream ) : make-unique-file ( prefix suffix -- path )
temporary-path -rot temporary-path -rot
[ [
unique-length random-name swap 3append append-path unique-length random-name swap 3append append-path
dup (make-unique-file) dup (make-unique-file)
] 3curry unique-retries retry ; ] 3curry unique-retries retry ;
: with-unique-file ( quot -- path ) : with-unique-file ( prefix suffix quot -- )
>r f f make-unique-file r> rot [ with-stream ] dip ; inline >r make-unique-file r> keep delete-file ; inline
: with-temporary-file ( quot -- )
with-unique-file delete-file ; inline
: make-unique-directory ( -- path ) : make-unique-directory ( -- path )
[ [
@ -40,12 +37,9 @@ PRIVATE>
dup make-directory dup make-directory
] unique-retries retry ; ] unique-retries retry ;
: with-unique-directory ( quot -- path ) : with-unique-directory ( quot -- )
>r make-unique-directory r> >r make-unique-directory r>
[ with-directory ] curry keep ; inline [ with-directory ] curry keep delete-tree ; inline
: with-temporary-directory ( quot -- )
with-unique-directory delete-tree ; inline
{ {
{ [ unix? ] [ "io.unix.files.unique" ] } { [ unix? ] [ "io.unix.files.unique" ] }

View File

@ -0,0 +1,5 @@
USING: io.backend kernel ;
IN: io.priority
HOOK: get-priority io-backend ( -- n )
HOOK: set-priority io-backend ( n -- )

View File

@ -72,6 +72,9 @@ M: mx unregister-io-task ( task mx -- )
: (io-error) ( -- * ) err_no strerror throw ; : (io-error) ( -- * ) err_no strerror throw ;
: check-errno ( -- )
err_no dup zero? [ drop ] [ strerror throw ] if ;
: check-null ( n -- ) zero? [ (io-error) ] when ; : check-null ( n -- ) zero? [ (io-error) ] when ;
: io-error ( n -- ) 0 < [ (io-error) ] when ; : io-error ( n -- ) 0 < [ (io-error) ] when ;

View File

@ -5,8 +5,7 @@ IN: io.unix.files.unique
: open-unique-flags ( -- flags ) : open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ; { O_RDWR O_CREAT O_EXCL } flags ;
M: unix-io (make-unique-file) ( path -- duplex-stream ) M: unix-io (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error open-unique-flags file-mode open dup io-error close ;
<writer> ;
M: unix-io temporary-path ( -- path ) "/tmp" ; M: unix-io temporary-path ( -- path ) "/tmp" ;

View File

@ -0,0 +1,21 @@
USING: alien.syntax kernel io.priority io.unix.backend
unix ;
IN: io.unix.priority
: PRIO_PROCESS 0 ; inline
: PRIO_PGRP 1 ; inline
: PRIO_USER 2 ; inline
: PRIO_MIN -20 ; inline
: PRIO_MAX 20 ; inline
! which/who = 0 for current process
FUNCTION: int getpriority ( int which, int who ) ;
FUNCTION: int setpriority ( int which, int who, int prio ) ;
M: unix-io get-priority ( -- n )
clear_err_no
0 0 getpriority dup -1 = [ check-errno ] when ;
M: unix-io set-priority ( n -- )
0 0 rot setpriority io-error ;

View File

@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend io.unix.launcher io.unix.mmap io.backend io.unix.priority
combinators namespaces system vocabs.loader sequences ; combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require "io.unix." os append require

View File

@ -1,9 +1,10 @@
USING: kernel system io.files.unique.backend USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking ; windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique IN: io.windows.files.unique
M: windows-io (make-unique-file) ( path -- stream ) M: windows-io (make-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ; GENERIC_WRITE CREATE_NEW 0 open-file
CloseHandle win32-error=0/f ;
M: windows-io temporary-path ( -- path ) M: windows-io temporary-path ( -- path )
"TEMP" os-env ; "TEMP" os-env ;

View File

@ -0,0 +1,21 @@
USING: help.syntax help.markup ;
IN: math.ranges
ARTICLE: "ranges" "Ranges"
"A " { $emphasis "range" } " is a virtual sequence with elements "
"ranging from a to b by step."
$nl
"Creating ranges:"
{ $subsection <range> }
{ $subsection [a,b] }
{ $subsection (a,b] }
{ $subsection [a,b) }
{ $subsection (a,b) }
{ $subsection [0,b] }
{ $subsection [1,b] }
{ $subsection [0,b) } ;

View File

@ -3,7 +3,7 @@ IN: math.ranges
TUPLE: range from length step ; TUPLE: range from length step ;
: <range> ( from to step -- range ) : <range> ( a b step -- range )
>r over - r> >r over - r>
[ / 1+ 0 max >integer ] keep [ / 1+ 0 max >integer ] keep
range construct-boa ; range construct-boa ;
@ -22,19 +22,19 @@ INSTANCE: range immutable-sequence
: ,b) dup neg rot + swap ; inline : ,b) dup neg rot + swap ; inline
: [a,b] twiddle <range> ; : [a,b] ( a b -- range ) twiddle <range> ;
: (a,b] twiddle (a, <range> ; : (a,b] ( a b -- range ) twiddle (a, <range> ;
: [a,b) twiddle ,b) <range> ; : [a,b) ( a b -- range ) twiddle ,b) <range> ;
: (a,b) twiddle (a, ,b) <range> ; : (a,b) ( a b -- range ) twiddle (a, ,b) <range> ;
: [0,b] 0 swap [a,b] ; : [0,b] ( b -- range ) 0 swap [a,b] ;
: [1,b] 1 swap [a,b] ; : [1,b] ( b -- range ) 1 swap [a,b] ;
: [0,b) 0 swap [a,b) ; : [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? ) : range-increasing? ( range -- ? )
range-step 0 > ; range-step 0 > ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1,67 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: effects words kernel sequences slots slots.private
assocs parser mirrors namespaces math vocabs tuples ;
IN: new-slots
: 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 [ slot ] 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-new-slot ( class slot name -- )
dup define-changer
dup define-setter
3dup define-reader
define-writer ;
: define-new-slots ( tuple-class -- )
[ "slot-names" word-prop <enum> >alist ] keep
[ swap first2 >r 4 + r> define-new-slot ] curry each ;
: TUPLE:
CREATE-CLASS
dup ";" parse-tokens define-tuple-class
define-new-slots ; parsing
"accessors" create-vocab drop

View File

@ -292,7 +292,7 @@ TUPLE: regexp source parser ignore-case? ;
: parse-regexp ( accum end -- accum ) : parse-regexp ( accum end -- accum )
lexer get dup skip-blank [ lexer get dup skip-blank [
[ index* dup 1+ swap ] 2keep swapd subseq swap [ index* dup 1+ swap ] 2keep swapd subseq swap
] change-column ] change-lexer-column
lexer get (parse-token) parse-options <regexp> parsed ; lexer get (parse-token) parse-options <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing : R! CHAR: ! parse-regexp ; parsing

View File

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

View File

@ -40,42 +40,57 @@ IN: tools.deploy.backend
"compiler" deploy-compiler? get ?, "compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?, "ui" deploy-ui? get ?,
"io" native-io? ?, "io" native-io? ?,
"random" deploy-random? get ?,
] { } make ; ] { } make ;
: staging-image-name ( -- name ) : staging-image-name ( profile -- name )
"staging." "staging."
bootstrap-profile strip-word-names? [ "strip" add ] when swap strip-word-names? [ "strip" add ] when
"-" join ".image" 3append ; "-" join ".image" 3append temp-file ;
: staging-command-line ( config -- flags ) DEFER: ?make-staging-image
: staging-command-line ( profile -- flags )
[ [
[ dup empty? [
"-i=" my-boot-image-name append , "-i=" my-boot-image-name append ,
] [
dup 1 head* ?make-staging-image
"-output-image=" staging-image-name append , "-resource-path=" "" resource-path append ,
"-include=" bootstrap-profile " " join append , "-i=" over 1 head* staging-image-name append ,
strip-word-names? [ "-no-stack-traces" , ] when "-run=tools.deploy.restage" ,
] if
"-no-user-init" , "-output-image=" over staging-image-name append ,
] { } make
] bind ; "-include=" swap " " join append ,
strip-word-names? [ "-no-stack-traces" , ] when
"-no-user-init" ,
] { } make ;
: run-factor ( vm flags -- ) : run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline swap add* dup . run-with-output ; inline
: make-staging-image ( config -- ) : make-staging-image ( profile -- )
vm swap staging-command-line run-factor ; vm swap staging-command-line run-factor ;
: ?make-staging-image ( config -- ) : ?make-staging-image ( profile -- )
dup [ staging-image-name ] bind exists? dup staging-image-name exists?
[ drop ] [ make-staging-image ] if ; [ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags ) : deploy-command-line ( image vocab config -- flags )
[ [
bootstrap-profile ?make-staging-image
[ [
"-i=" staging-image-name append , "-i=" bootstrap-profile staging-image-name append ,
"-resource-path=" "" resource-path append ,
"-run=tools.deploy.shaker" , "-run=tools.deploy.shaker" ,
@ -89,7 +104,6 @@ IN: tools.deploy.backend
: make-deploy-image ( vm image vocab config -- ) : make-deploy-image ( vm image vocab config -- )
make-boot-image make-boot-image
dup ?make-staging-image
deploy-command-line run-factor ; deploy-command-line run-factor ;
SYMBOL: deploy-implementation SYMBOL: deploy-implementation

View File

@ -16,6 +16,8 @@ ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? } { $subsection deploy-math? }
{ $subsection deploy-compiler? } { $subsection deploy-compiler? }
{ $subsection deploy-random? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? } { $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
{ $subsection deploy-io } { $subsection deploy-io }
@ -66,16 +68,21 @@ HELP: deploy-math?
$nl $nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, the deployed image will contain support for threads."
$nl
"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
HELP: deploy-compiler? HELP: deploy-compiler?
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible." { $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
$nl $nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
HELP: deploy-random?
{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
$nl
"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
$nl
"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
HELP: deploy-ui? HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image." { $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
$nl $nl

View File

@ -10,6 +10,7 @@ SYMBOL: deploy-name
SYMBOL: deploy-ui? SYMBOL: deploy-ui?
SYMBOL: deploy-compiler? SYMBOL: deploy-compiler?
SYMBOL: deploy-math? SYMBOL: deploy-math?
SYMBOL: deploy-random?
SYMBOL: deploy-threads? SYMBOL: deploy-threads?
SYMBOL: deploy-io SYMBOL: deploy-io
@ -57,6 +58,7 @@ SYMBOL: deploy-image
{ deploy-reflection 1 } { deploy-reflection 1 }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-threads? t } { deploy-threads? t }
{ deploy-random? t }
{ deploy-math? t } { deploy-math? t }
{ deploy-word-props? f } { deploy-word-props? f }
{ deploy-word-defs? f } { deploy-word-defs? f }

View File

@ -28,7 +28,8 @@ namespaces ;
[ ] [ "hello-ui" shake-and-bake ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [ [ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config [ staging-image-name ] bind "hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test ] unit-test
[ t ] [ [ t ] [

View File

@ -0,0 +1,8 @@
IN: tools.deploy.restage
USING: bootstrap.stage2 namespaces memory ;
: restage ( -- )
load-components
"output-image" get save-image-and-exit ;
MAIN: restage

View File

@ -19,7 +19,6 @@ QUALIFIED: libc.private
QUALIFIED: libc.private QUALIFIED: libc.private
QUALIFIED: listener QUALIFIED: listener
QUALIFIED: prettyprint.config QUALIFIED: prettyprint.config
QUALIFIED: random.private
QUALIFIED: source-files QUALIFIED: source-files
QUALIFIED: threads QUALIFIED: threads
QUALIFIED: vocabs QUALIFIED: vocabs
@ -108,8 +107,6 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq ) : stripped-globals ( -- seq )
[ [
random.private:mt ,
{ {
bootstrap.stage2:bootstrap-time bootstrap.stage2:bootstrap-time
continuations:error continuations:error
@ -145,12 +142,14 @@ IN: tools.deploy.shaker
vocabs:dictionary vocabs:dictionary
lexer-factory lexer-factory
vocabs:load-vocab-hook vocabs:load-vocab-hook
root-cache
layouts:num-tags layouts:num-tags
layouts:num-types layouts:num-types
layouts:tag-mask layouts:tag-mask
layouts:tag-numbers layouts:tag-numbers
layouts:type-numbers layouts:type-numbers
classes:typemap classes:typemap
classes:class-map
vocab-roots vocab-roots
definitions:crossref definitions:crossref
compiled-crossref compiled-crossref

View File

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

View File

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

View File

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

View File

@ -34,8 +34,13 @@ IN: tools.vocabs
: source-modified? ( path -- ? ) : source-modified? ( path -- ? )
dup source-files get at [ dup source-files get at [
dup source-file-path ?resource-path utf8 file-lines lines-crc32 dup source-file-path ?resource-path
swap source-file-checksum = not dup exists? [
utf8 file-lines lines-crc32
swap source-file-checksum = not
] [
2drop f
] if
] [ ] [
resource-exists? resource-exists?
] ?if ; ] ?if ;

View File

@ -46,7 +46,7 @@ M: array rect-dim drop { 0 0 } ;
TUPLE: gadget TUPLE: gadget
pref-dim parent children orientation focus pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state visible? root? clipped? layout-state graft-state graft-node
interior boundary interior boundary
model ; model ;
@ -254,17 +254,20 @@ M: gadget layout* drop ;
: graft-queue \ graft-queue get ; : graft-queue \ graft-queue get ;
: unqueue-graft ( gadget -- ) : unqueue-graft ( gadget -- )
dup graft-queue dlist-delete [ "Not queued" throw ] unless graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ? dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ; swap set-gadget-graft-state ;
: (queue-graft) ( gadget flags -- )
over set-gadget-graft-state
dup graft-queue push-front* swap set-gadget-graft-node
notify-ui-thread ;
: queue-graft ( gadget -- ) : queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state { f t } (queue-graft) ;
graft-queue push-front notify-ui-thread ;
: queue-ungraft ( gadget -- ) : queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state { t f } (queue-graft) ;
graft-queue push-front notify-ui-thread ;
: graft-later ( gadget -- ) : graft-later ( gadget -- )
dup gadget-graft-state { dup gadget-graft-state {

View File

@ -35,6 +35,7 @@ TUPLE: deploy-gadget vocab settings ;
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget, deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
deploy-math? get "Rational and complex number support" <checkbox> gadget, deploy-math? get "Rational and complex number support" <checkbox> gadget,
deploy-threads? get "Threading support" <checkbox> gadget, deploy-threads? get "Threading support" <checkbox> gadget,
deploy-random? get "Random number generator support" <checkbox> gadget,
deploy-word-props? get "Retain all word properties" <checkbox> gadget, deploy-word-props? get "Retain all word properties" <checkbox> gadget,
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget, deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ; deploy-c-types? get "Retain all C types" <checkbox> gadget, ;

View File

@ -0,0 +1,30 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
C-STRUCT: stat
{ "__dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
{ "timespec" "st_atim" }
{ "timespec" "st_mtim" }
{ "timespec" "st_ctim" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "fflags_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "timespec" "st_birthtimespec" }
! not sure about the padding here.
{ "__uint32_t" "pad0" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

View File

@ -0,0 +1,30 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
! untested
C-STRUCT: stat
{ "__dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
{ "timespec" "st_atim" }
{ "timespec" "st_mtim" }
{ "timespec" "st_ctim" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "fflags_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "timespec" "st_birthtimespec" }
! not sure about the padding here.
{ "__uint32_t" "pad0" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

View File

@ -1,30 +1,7 @@
USING: kernel alien.syntax math ; USING: layouts combinators vocabs.loader ;
IN: unix.stat IN: unix.stat
! FreeBSD 8.0-CURRENT cell-bits {
{ 32 [ "unix.stat.freebsd.32" require ] }
C-STRUCT: stat { 64 [ "unix.stat.freebsd.64" require ] }
{ "__dev_t" "st_dev" } } case
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
{ "timespec" "st_atim" }
{ "timespec" "st_mtim" }
{ "timespec" "st_ctim" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "fflags_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "timespec" "st_birthtimespec" }
! not sure about the padding here.
{ "__uint32_t" "pad0" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

View File

@ -0,0 +1,26 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! NetBSD 4.0
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "mode_t" "st_mode" }
{ "ino_t" "st_ino" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atim" }
{ "timespec" "st_mtim" }
{ "timespec" "st_ctim" }
{ "timespec" "st_birthtim" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ { "uint32_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

View File

@ -0,0 +1,28 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! OpenBSD 4.2
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
{ "timespec" "st_atim" }
{ "timespec" "st_mtim" }
{ "timespec" "st_ctim" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
{ "timespec" "st_birthtim" }
{ { "int64_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

View File

@ -63,7 +63,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
{ "linux" [ "unix.stat.linux" require ] } { "linux" [ "unix.stat.linux" require ] }
{ "macosx" [ "unix.stat.macosx" require ] } { "macosx" [ "unix.stat.macosx" require ] }
{ "freebsd" [ "unix.stat.freebsd" require ] } { "freebsd" [ "unix.stat.freebsd" require ] }
[ drop ] { "netbsd" [ "unix.stat.netbsd" require ] }
{ "openbsd" [ "unix.stat.openbsd" require ] }
} }
case case
>> >>

View File

@ -0,0 +1,32 @@
USING: alien.syntax ;
IN: unix.types
! NetBSD 4.0
TYPEDEF: short __int16_t
TYPEDEF: ushort __uint16_t
TYPEDEF: int __int32_t
TYPEDEF: uint __uint32_t
TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
TYPEDEF: uint uint32_t
TYPEDEF: uint u_int32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint64_t ino_t
TYPEDEF: __uint32_t mode_t
TYPEDEF: __uint32_t nlink_t
TYPEDEF: __uint32_t uid_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
TYPEDEF: __uint32_t fflags_t
TYPEDEF: int ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t

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