* Contents
-- Platform support
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
- Source organization
- Community
-* Platform support
-
-Factor supports the following platforms:
-
- Linux/x86
- Linux/AMD64
- Linux/PowerPC
- Linux/ARM
- Mac OS X/x86
- Mac OS X/PowerPC
- FreeBSD/x86
- FreeBSD/AMD64
- OpenBSD/x86
- OpenBSD/AMD64
- Solaris/x86
- Solaris/AMD64
- MS Windows/x86 (XP and above)
- MS Windows CE/ARM
-
-Please donate time or hardware if you wish to see Factor running on
-other platforms. In particular, we are interested in:
-
- Windows/AMD64
- Mac OS X/AMD64
- Solaris/UltraSPARC
- Linux/MIPS
-
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
-Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
-3.3 or earlier. If you are using gcc 4.3, you might get an unusable
-Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
-command-line arguments for make.
+Factor supports various platforms. For an up-to-date list, see
+<http://factorcode.org/getfactor.fhtml>.
+
+Factor requires gcc 3.4 or later.
+
+On x86, Factor /will not/ build using gcc 3.3 or earlier.
+
+If you are using gcc 4.3, you might get an unusable Factor binary unless
+you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
+arguments for make.
-Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
-targets and build options. Then run 'make' with the appropriate target
-for your platform.
+Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix,
-'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
+'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation
-For X11 support, you need recent development libraries for libc, Freetype,
-X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
-you can use the line
+For X11 support, you need recent development libraries for libc,
+Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the line
-sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-to grab everything (if you're on a non-debian-derived distro please tell us
-what the equivalent command is on there and it can be added :)
+to grab everything (if you're on a non-debian-derived distro please tell
+us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
-The boot images are no longer included with the Factor distribution
-due to size concerns. Instead, download a boot image from:
-
- http://factorcode.org/images/
-
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
-Once you download the right image, bootstrap the system with the
+Boot images can be obtained from <http://factorcode.org/images/latest/>.
+
+Once you download the right image, bootstrap Factor with the
following command line:
./factor -i=boot.<cpu>.image
-Or this command for Mac OS X systems:
-
-./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
-
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
* Running Factor on Mac OS X - Cocoa UI
-On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
-terminal listener. If you are using Mac OS X 10.3, you can only run the
-X11 UI, as documented in the next section.
+On Mac OS X, a Cocoa UI is available in addition to the terminal
+listener.
The 'factor' executable runs the terminal listener:
* Running Factor on Mac OS X - X11 UI
-The X11 UI is available on Mac OS X, however its use is not recommended
-since it does not integrate with the host OS. However, if you are
-running Mac OS X 10.3, it is your only choice.
+The X11 UI is also available on Mac OS X, however its use is not
+recommended since it does not integrate with the host OS.
When compiling Factor, pass the X11=1 parameter:
- make macosx-ppc X11=1
+ make X11=1
Then bootstrap with the following switches:
- ./factor -i=boot.ppc.image -ui-backend=x11
+ ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
- factor-nt.exe -i=boot.x86.32.image
+ factor.exe -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt:
- factor-nt.exe -run=listener
+ factor.exe -run=listener
* The Factor FAQ
-The Factor FAQ lives online at http://factorcode.org/faq.fhtml
+The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
* Command line usage
-The Factor VM supports a number of command line switches. To read
-command line usage documentation, either enter the following in the UI
-listener:
+Factor supports a number of command line switches. To read command line
+usage documentation, enter the following in the UI listener:
"command-line" about
* Source organization
-The following two directories are managed by the module system; consult
-the documentation for details:
+The Factor source tree is organized as follows:
+ build-support/ - scripts used for compiling Factor
core/ - Factor core library and compiler
extra/ - more libraries
-
-The following directories contain additional files:
-
- misc/ - editor modes, icons, etc
- vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI
+ misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
+ vm/ - sources for the Factor VM, written in C
* Community
i386) ARCH=x86;;
i686) ARCH=x86;;
amd64) ARCH=x86;;
+ ppc64) ARCH=ppc;;
*86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
"<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
- " { [ t ] [ drop ] }"
+ " [ drop ]"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
$nl
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
-{ $code "USE: alien callbacks get clear-hash code-gc" }
+{ $code "USE: alien callbacks get clear-hash gc" }
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
ARTICLE: "alien-callback" "Calling Factor from C"
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
- over dup [ dlopen ] when \ library construct-boa ;
+ over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll )
library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
-TUPLE: alien-callback return parameters abi quot xt ;
-
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
alien-callback-error ;
-TUPLE: alien-indirect return parameters abi ;
-
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
-TUPLE: alien-invoke library function return parameters abi ;
-
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
M: array stack-size drop "void*" stack-size ;
-M: value-type c-type-reg-class drop T{ int-regs } ;
+M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;
generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
-layouts system compiler.units io.files io.encodings.binary ;
+layouts system compiler.units io.files io.encodings.binary
+accessors combinators ;
IN: alien.c-types
DEFER: <int>
getter setter
reg-class size align stack-align? ;
+: new-c-type ( class -- type )
+ new
+ int-regs >>reg-class ;
+
: <c-type> ( -- type )
- T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
+ \ c-type new-c-type ;
SYMBOL: c-types
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-TUPLE: long-long-type ;
+TUPLE: long-long-type < c-type ;
-: <long-long-type> ( type -- type )
- long-long-type construct-delegate ;
+: <long-long-type> ( -- type )
+ long-long-type new-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
-: <primitive-type> ( getter setter width boxer unboxer -- type )
- <c-type>
- [ set-c-type-unboxer ] keep
- [ set-c-type-boxer ] keep
- [ set-c-type-size ] 2keep
- [ set-c-type-align ] keep
- [ set-c-type-setter ] keep
- [ set-c-type-getter ] keep ;
-
: define-primitive-type ( type name -- )
"alien.c-types"
- [ define-c-type ] 2keep
- [ define-deref ] 2keep
- [ define-to-array ] 2keep
- [ define-from-array ] 2keep
- define-out ;
+ {
+ [ define-c-type ]
+ [ define-deref ]
+ [ define-to-array ]
+ [ define-from-array ]
+ [ define-out ]
+ } 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
binary file-contents dup malloc-byte-array swap length ;
[
- [ alien-cell ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_alien"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_alien" >>boxer
+ "alien_offset" >>unboxer
"void*" define-primitive-type
- [ alien-signed-8 ]
- [ set-alien-signed-8 ]
- 8
- "box_signed_8"
- "to_signed_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_signed_8" >>boxer
+ "to_signed_8" >>unboxer
"longlong" define-primitive-type
- [ alien-unsigned-8 ]
- [ set-alien-unsigned-8 ]
- 8
- "box_unsigned_8"
- "to_unsigned_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
- [ alien-signed-cell ]
- [ set-alien-signed-cell ]
- bootstrap-cell
- "box_signed_cell"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
"long" define-primitive-type
- [ alien-unsigned-cell ]
- [ set-alien-unsigned-cell ]
- bootstrap-cell
- "box_unsigned_cell"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
"ulong" define-primitive-type
- [ alien-signed-4 ]
- [ set-alien-signed-4 ]
- 4
- "box_signed_4"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-4 ] >>getter
+ [ set-alien-signed-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_signed_4" >>boxer
+ "to_fixnum" >>unboxer
"int" define-primitive-type
- [ alien-unsigned-4 ]
- [ set-alien-unsigned-4 ]
- 4
- "box_unsigned_4"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 ] >>getter
+ [ set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_unsigned_4" >>boxer
+ "to_cell" >>unboxer
"uint" define-primitive-type
- [ alien-signed-2 ]
- [ set-alien-signed-2 ]
- 2
- "box_signed_2"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-2 ] >>getter
+ [ set-alien-signed-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_signed_2" >>boxer
+ "to_fixnum" >>unboxer
"short" define-primitive-type
- [ alien-unsigned-2 ]
- [ set-alien-unsigned-2 ]
- 2
- "box_unsigned_2"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-2 ] >>getter
+ [ set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_unsigned_2" >>boxer
+ "to_cell" >>unboxer
"ushort" define-primitive-type
- [ alien-signed-1 ]
- [ set-alien-signed-1 ]
- 1
- "box_signed_1"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-1 ] >>getter
+ [ set-alien-signed-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_signed_1" >>boxer
+ "to_fixnum" >>unboxer
"char" define-primitive-type
- [ alien-unsigned-1 ]
- [ set-alien-unsigned-1 ]
- 1
- "box_unsigned_1"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-1 ] >>getter
+ [ set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_unsigned_1" >>boxer
+ "to_cell" >>unboxer
"uchar" define-primitive-type
- [ alien-unsigned-4 zero? not ]
- [ 1 0 ? set-alien-unsigned-4 ]
- 4
- "box_boolean"
- "to_boolean" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 zero? not ] >>getter
+ [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
"bool" define-primitive-type
- [ alien-float ]
- [ >r >r >float r> r> set-alien-float ]
- 4
- "box_float"
- "to_float" <primitive-type>
+ <c-type>
+ [ alien-float ] >>getter
+ [ >r >r >float r> r> set-alien-float ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_float" >>boxer
+ "to_float" >>unboxer
+ single-float-regs >>reg-class
+ [ >float ] >>prep
"float" define-primitive-type
- T{ float-regs f 4 } "float" c-type set-c-type-reg-class
- [ >float ] "float" c-type set-c-type-prep
-
- [ alien-double ]
- [ >r >r >float r> r> set-alien-double ]
- 8
- "box_double"
- "to_double" <primitive-type>
+ <c-type>
+ [ alien-double ] >>getter
+ [ >r >r >float r> r> set-alien-double ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_double" >>boxer
+ "to_double" >>unboxer
+ double-float-regs >>reg-class
+ [ >float ] >>prep
"double" define-primitive-type
- T{ float-regs f 8 } "double" c-type set-c-type-reg-class
- [ >float ] "double" c-type set-c-type-prep
-
- [ alien-cell alien>char-string ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_char_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>char-string ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_char_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
- [ string>char-alien ] "char*" c-type set-c-type-prep
-
- [ alien-cell alien>u16-string ]
- [ set-alien-cell ]
- 4
- "box_u16_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>u16-string ] >>getter
+ [ set-alien-cell ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_u16_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>u16-alien ] >>prep
"ushort*" define-primitive-type
- [ string>u16-alien ] "ushort*" c-type set-c-type-prep
-
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
-
] with-compilation-unit
namespaces namespaces tools.test sequences inference words\r
arrays parser quotations continuations inference.backend effects\r
namespaces.private io io.streams.string memory system threads\r
-tools.test ;\r
+tools.test math ;\r
\r
FUNCTION: void ffi_test_0 ;\r
[ ] [ ffi_test_0 ] unit-test\r
[ -1 indirect-test-1 ] must-fail\r
\r
: indirect-test-2\r
- "int" { "int" "int" } "cdecl" alien-indirect data-gc ;\r
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;\r
\r
{ 3 1 } [ indirect-test-2 ] must-infer-as\r
\r
\r
: indirect-test-3\r
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect\r
- data-gc ;\r
+ gc ;\r
\r
<< "f-stdcall" f "stdcall" add-library >>\r
\r
\r
: ffi_test_18 ( w x y z -- int )\r
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }\r
- alien-invoke data-gc ;\r
+ alien-invoke gc ;\r
\r
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test\r
\r
: ffi_test_19 ( x y z -- bar )\r
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }\r
- alien-invoke data-gc ;\r
+ alien-invoke gc ;\r
\r
[ 11 6 -7 ] [\r
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z\r
"void"\r
f "ffi_test_31"\r
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }\r
- alien-invoke code-gc 3 ;\r
+ alien-invoke gc 3 ;\r
\r
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test\r
\r
\r
: callback-4\r
"void" { } "cdecl" [ "Hello world" write ] alien-callback\r
- data-gc ;\r
+ gc ;\r
\r
[ "Hello world" ] [ \r
[ callback-4 callback_test_1 ] with-string-writer\r
] unit-test\r
\r
: callback-5\r
- "void" { } "cdecl" [ data-gc ] alien-callback ;\r
+ "void" { } "cdecl" [ gc ] alien-callback ;\r
\r
[ "testing" ] [\r
"testing" callback-5 callback_test_1\r
] alien-callback ;\r
\r
[ ] [ callback-8 callback_test_1 ] unit-test\r
+\r
+: callback-9\r
+ "int" { "int" "int" "int" } "cdecl" [\r
+ + + 1+\r
+ ] alien-callback ;\r
+\r
+FUNCTION: int ffi_test_37 ( void* func ) ;\r
+\r
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test\r
+\r
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test\r
compiler.errors continuations layouts accessors ;
IN: alien.compiler
+TUPLE: #alien-node < node return parameters abi ;
+
+TUPLE: #alien-callback < #alien-node quot xt ;
+
+TUPLE: #alien-indirect < #alien-node ;
+
+TUPLE: #alien-invoke < #alien-node library function ;
+
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
M: int-regs reg-size drop cell ;
-M: float-regs reg-size float-regs-size ;
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
-: (inc-reg-class)
- dup class inc
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
M: float-regs inc-reg-class
- dup (inc-reg-class)
+ dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
- dup class get swap param-regs length >= ;
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
- reg-size stack-params dup get -rot +@ T{ stack-params } ;
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
: fastcall-param ( reg-class -- n reg-class )
- [ dup class get swap inc-reg-class ] keep ;
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
drop +linkage+ ;
: no-such-library ( name -- )
- \ no-such-library construct-boa
+ \ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
drop +linkage+ ;
: no-such-symbol ( name -- )
- \ no-such-symbol construct-boa
+ \ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
- dup alien-invoke-function dup pick stdcall-mangle 2array
- swap alien-invoke-library library dup [ library-dll ] when
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
4 ensure-values
- \ alien-invoke empty-node
+ #alien-invoke new
! Compile-time parameters
- pop-parameters over set-alien-invoke-parameters
- pop-literal nip over set-alien-invoke-function
- pop-literal nip over set-alien-invoke-library
- pop-literal nip over set-alien-invoke-return
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
- dup alien-invoke-library
- library [ library-abi ] [ "cdecl" ] if*
- over set-alien-invoke-abi
+ dup library>>
+ library [ abi>> ] [ "cdecl" ] if*
+ >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
] "infer" set-word-prop
-M: alien-invoke generate-node
+M: #alien-invoke generate-node
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
! Three literals and function pointer
4 ensure-values
4 reify-curries
- \ alien-indirect empty-node
+ #alien-indirect new
! Compile-time parameters
- pop-literal nip over set-alien-indirect-abi
- pop-parameters over set-alien-indirect-parameters
- pop-literal nip over set-alien-indirect-return
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
1 alien-invoke-stack
] "infer" set-word-prop
-M: alien-indirect generate-node
+M: #alien-indirect generate-node
dup alien-invoke-frame [
! Flush registers
end-basic-block
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
-
alien-callback-xt [ word-xt drop <alien> ] curry
+
xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values
- \ alien-callback empty-node dup node,
- pop-literal nip over set-alien-callback-quot
- pop-literal nip over set-alien-callback-abi
- pop-parameters over set-alien-callback-parameters
- pop-literal nip over set-alien-callback-return
- gensym dup register-callback over set-alien-callback-xt
+ #alien-callback new dup node,
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym dup register-callback >>xt
callback-bottom
] "infer" set-word-prop
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- { [ t ] [ c-type c-type-prep ] }
+ [ c-type c-type-prep ]
} cond ;
: wrap-callback-quot ( node -- quot )
[
- dup alien-callback-quot
- swap prepare-callback-return append ,
- [ callback-context construct-empty do-callback ] %
+ [ quot>> ] [ prepare-callback-return ] bi append ,
+ [ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
{
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
- { [ t ] [ drop 0 ] }
+ [ drop 0 ]
} cond ;
: %callback-return ( node -- )
callback-unwind %unwind ;
: generate-callback ( node -- )
- dup alien-callback-xt dup [
+ dup xt>> dup [
init-templates
- %save-word-xt
%prologue-later
dup alien-stack-frame [
dup registers>objects
] with-stack-frame
] with-generator ;
-M: alien-callback generate-node
+M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ;
: (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r>
- struct-type construct-boa
+ struct-type boa
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )
{
{ [ dup expired? ] [ drop "( alien expired )" text ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
- { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
+ [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
: >array ( seq -- array ) { } clone-like ;
-M: object new drop f <array> ;
+M: object new
-sequence drop f <array> ;
-M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
+M: f new
-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ;
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? }
-{ $subsection intersect }
+{ $subsection assoc-intersect }
{ $subsection update }
-{ $subsection union }
-{ $subsection diff }
+{ $subsection assoc-union }
+{ $subsection assoc-diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
-{ $see-also key? } ;
+{ $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
+{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
{ $subsection cache }
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
+HELP: assoc-contains?
+{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
+
HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
+{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ keys values } related-words
-HELP: intersect
+HELP: assoc-intersect
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
-HELP: union
+HELP: assoc-union
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
-HELP: diff
+HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
;
] [
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
- intersect
+ assoc-intersect
] unit-test
[
H{ { 1 2 } { 2 3 } { 6 5 } }
] [
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
- union
+ assoc-union
] unit-test
[ H{ { 1 2 } { 2 3 } } t ] [
- f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
+ f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
[
H{ { 1 f } }
] [
- H{ { 1 f } } H{ { 1 f } } intersect
+ H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ;
-: intersect ( assoc1 assoc2 -- intersection )
+: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
-: union ( assoc1 assoc2 -- union )
+: assoc-union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
-: diff ( assoc1 assoc2 -- diff )
+: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
: remove-all ( assoc seq -- subseq )
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
+: zip ( keys values -- alist )
+ 2array flip ; inline
+
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep 2array flip ;
+ seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ;
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
-M: bit-array new drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: bit-array>vector ( bit-array length -- bit-vector )\r
- bit-vector construct-boa ; inline\r
+ bit-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length bit-array>vector ] [ >bit-vector ] if\r
] unless ;\r
\r
-M: bit-vector new\r
+M: bit-vector new-sequence\r
drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
\r
M: bit-vector equal?\r
--- /dev/null
+Growable bit arrays
--- /dev/null
+collections
enable-compiler
nl
-"Compiling some words to speed up bootstrap..." write flush
+"Compiling..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
wrap probe
- delegate
-
underlying
find-pair-next namestack*
"." write flush
{
- new nth push pop peek
+ new-sequence nth push pop peek
} compile
"." write flush
malloc calloc free memcpy
} compile
+vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+
" done" print flush
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.tuple classes.tuple.private
-words.private io.binary io.files vocabs vocabs.loader
-source-files definitions debugger float-arrays
+splitting growable classes classes.builtin classes.tuple
+classes.tuple.private words.private io.binary io.files vocabs
+vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
IN: bootstrap.image
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
-} union type-numbers set
+} assoc-union type-numbers set
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
-classes.tuple classes.tuple.private kernel.private vocabs
-vocabs.loader source-files definitions slots.deprecated
-classes.union compiler.units bootstrap.image.private io.files
-accessors combinators ;
+classes.builtin classes.tuple classes.tuple.private
+kernel.private vocabs vocabs.loader source-files definitions
+slots.deprecated classes.union compiler.units
+bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
-H{ } clone changed-words set
+H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
! Create special tombstone values
"tombstone" "hashtables.private" create
-"tuple" "kernel" lookup
+tuple
{ } define-tuple-class
"((empty))" "hashtables.private" create
! Some tuple classes
"hashtable" "hashtables" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "array-capacity" "sequences.private" }
} define-tuple-class
"sbuf" "sbufs" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "string" "strings" }
} define-tuple-class
"vector" "vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "array" "arrays" }
} define-tuple-class
"byte-vector" "byte-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "byte-array" "byte-arrays" }
} define-tuple-class
"bit-vector" "bit-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "bit-array" "bit-arrays" }
} define-tuple-class
"float-vector" "float-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "float-array" "float-arrays" }
} define-tuple-class
"curry" "kernel" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "object" "kernel" }
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "object" "kernel" }
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
- { "data-gc" "memory" }
- { "code-gc" "memory" }
+ { "gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system.private" }
+ { "set-os-env" "system" }
+ { "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
+ { "unimplemented" "kernel.private" }
}
dup length [ >r first2 r> make-primitive ] 2each
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
-math.parser generic ;
+math.parser generic sets ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@
- seq-diff
+ diff
[ "bootstrap." prepend require ] each ;
-: compile-remaining ( -- )
- "Compiling remaining words..." print flush
- vocabs [ words [ compiled? not ] subset compile ] each ;
-
: count-words ( pred -- )
all-words swap subset length number>string write ;
default-image-name "output-image" set-global
-"math help handbook compiler random tools ui ui.tools io" "include" set-global
+"math compiler help random tools ui ui.tools io handbook" "include" set-global
"" "exclude" set-global
parse-command-line
load-components
run-bootstrap-init
-
- "bootstrap.compiler" vocab [
- compile-remaining
- ] when
] with-compiler-errors
:errors
\r
TUPLE: box value full? ;\r
\r
-: <box> ( -- box ) box construct-empty ;\r
+: <box> ( -- box ) box new ;\r
\r
: >box ( value box -- )\r
dup box-full? [ "Box already has a value" throw ] when\r
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
-M: byte-array new drop <byte-array> ;
+M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector construct-boa ; inline\r
+ byte-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length byte-array>vector ] [ >byte-vector ] if\r
] unless ;\r
\r
-M: byte-vector new\r
+M: byte-vector new-sequence\r
drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
\r
M: byte-vector equal?\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
[ t ] [ \ tuple-class \ class class< ] unit-test\r
[ f ] [ \ class \ tuple-class class< ] unit-test\r
\r
-TUPLE: delegate-clone ;\r
+TUPLE: tuple-example ;\r
\r
-[ t ] [ \ null \ delegate-clone class< ] unit-test\r
-[ f ] [ \ object \ delegate-clone class< ] unit-test\r
-[ f ] [ \ object \ delegate-clone class< ] unit-test\r
-[ t ] [ \ delegate-clone \ tuple class< ] unit-test\r
-[ f ] [ \ tuple \ delegate-clone class< ] unit-test\r
+[ t ] [ \ null \ tuple-example class< ] unit-test\r
+[ f ] [ \ object \ tuple-example class< ] unit-test\r
+[ f ] [ \ object \ tuple-example class< ] unit-test\r
+[ t ] [ \ tuple-example \ tuple class< ] unit-test\r
+[ f ] [ \ tuple \ tuple-example class< ] unit-test\r
\r
TUPLE: a1 ;\r
TUPLE: b1 ;\r
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel classes combinators accessors sequences arrays\r
-vectors assocs namespaces words sorting layouts math hashtables\r
-kernel.private ;\r
+USING: kernel classes classes.builtin combinators accessors\r
+sequences arrays vectors assocs namespaces words sorting layouts\r
+math hashtables kernel.private sets ;\r
IN: classes.algebra\r
\r
: 2cache ( key1 key2 assoc quot -- value )\r
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
{ [ dup members ] [ right-union-class< ] }\r
{ [ over superclass ] [ superclass< ] }\r
- { [ t ] [ 2drop f ] }\r
+ [ 2drop f ]\r
} cond ;\r
\r
: anonymous-union-intersect? ( first second -- ? )\r
{\r
{ [ over tuple eq? ] [ 2drop t ] }\r
{ [ over builtin-class? ] [ 2drop f ] }\r
- { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }\r
- { [ t ] [ swap classes-intersect? ] }\r
+ { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }\r
+ [ swap classes-intersect? ]\r
} cond ;\r
\r
: builtin-class-intersect? ( first second -- ? )\r
{\r
{ [ 2dup eq? ] [ 2drop t ] }\r
{ [ over builtin-class? ] [ 2drop f ] }\r
- { [ t ] [ swap classes-intersect? ] }\r
+ [ swap classes-intersect? ]\r
} cond ;\r
\r
: (classes-intersect?) ( first second -- ? )\r
{ [ over members ] [ left-union-and ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }\r
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }\r
- { [ t ] [ 2array <anonymous-intersection> ] }\r
+ [ 2array <anonymous-intersection> ]\r
} cond ;\r
\r
: left-anonymous-union-or ( first second -- class )\r
{ [ 2dup swap class< ] [ drop ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }\r
- { [ t ] [ 2array <anonymous-union> ] }\r
+ [ 2array <anonymous-union> ]\r
} cond ;\r
\r
: (class-not) ( class -- complement )\r
{ [ dup anonymous-complement? ] [ class>> ] }\r
{ [ dup object eq? ] [ drop null ] }\r
{ [ dup null eq? ] [ drop object ] }\r
- { [ t ] [ <anonymous-complement> ] }\r
+ [ <anonymous-complement> ]\r
} cond ;\r
\r
: largest-class ( seq -- n elt )\r
{ [ dup builtin-class? ] [ dup set ] }\r
{ [ dup members ] [ members [ (flatten-class) ] each ] }\r
{ [ dup superclass ] [ superclass (flatten-class) ] }\r
- { [ t ] [ drop ] }\r
+ [ drop ]\r
} cond ;\r
\r
: flatten-class ( class -- assoc )\r
--- /dev/null
+USING: help.syntax help.markup classes layouts ;
+IN: classes.builtin
+
+ARTICLE: "builtin-classes" "Built-in classes"
+"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
+$nl
+"The set of built-in classes is a class:"
+{ $subsection builtin-class }
+{ $subsection builtin-class? }
+"See " { $link "type-index" } " for a list of built-in classes." ;
+
+HELP: builtin-class
+{ $class-description "The class of built-in classes." }
+{ $examples
+ "The class of arrays is a built-in class:"
+ { $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" }
+ "However, an instance of the array class is not a built-in class; it is not even a class:"
+ { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
+} ;
+
+HELP: builtins
+{ $var-description "Vector mapping type numbers to builtin class words." } ;
+
+HELP: type>class
+{ $values { "n" "a non-negative integer" } { "class" class } }
+{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
+{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
+
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes words kernel kernel.private namespaces
+sequences ;
+IN: classes.builtin
+
+SYMBOL: builtins
+
+PREDICATE: builtin-class < class
+ "metaclass" word-prop builtin-class eq? ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
+
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
classes.predicate quotations ;
IN: classes
-ARTICLE: "builtin-classes" "Built-in classes"
-"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
-$nl
-"The set of built-in classes is a class:"
-{ $subsection builtin-class }
-{ $subsection builtin-class? }
-"See " { $link "type-index" } " for a list of built-in classes." ;
-
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
{ $subsection class? }
"You can ask an object for its class:"
{ $subsection class }
+"Testing if an object is an instance of a class:"
+{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
"Obtaining a list of all defined classes:"
{ $subsection classes }
-"Other sorts of classes:"
+"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
-{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
+{ $subsection "singletons" }
+{ $link "tuples" } " are documented in their own section."
+$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $see-also "class-index" } ;
HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
-{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
+{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: builtin-class
-{ $class-description "The class of built-in classes." }
-{ $examples
- "The class of arrays is a built-in class:"
- { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
- "However, an instance of the array class is not a built-in class; it is not even a class:"
- { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
-} ;
-
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-HELP: builtins
-{ $var-description "Vector mapping type numbers to builtin class words." } ;
-
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
-HELP: type>class
-{ $values { "n" "a non-negative integer" } { "class" class } }
-{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
-{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
-
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
PREDICATE: class < word
"class" word-prop ;
-SYMBOL: builtins
-
-PREDICATE: builtin-class < class
- "metaclass" word-prop builtin-class eq? ;
-
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
-: type>class ( n -- class ) builtins get-global nth ;
-
-: bootstrap-type>class ( n -- class ) builtins get nth ;
-
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
- r> union over set-word-props
+ r> assoc-union over set-word-props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
GENERIC: class ( object -- class )
-M: hi-tag class hi-tag type>class ;
-
-M: object class tag type>class ;
-
: instance? ( obj class -- ? )
"predicate" word-prop call ;
USING: help.markup help.syntax help words compiler.units
-classes ;
+classes sequences ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
-"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin."
+"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class }
{ $subsection add-mixin-instance }
"The set of mixin classes is a class:"
{ $subsection mixin-class }
-{ $subsection mixin-class? } ;
+{ $subsection mixin-class? }
+"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
+{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
- \ check-mixin-class construct-boa throw
+ \ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
{ [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
- { [ t ] [ t ] }
+ [ t ]
} cond 2nip ;
M: mixin-instance hashcode*
IN: classes.singleton
ARTICLE: "singletons" "Singleton classes"
-"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes."
+"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
-{ $subsection define-singleton-class } ;
+{ $subsection define-singleton-class }
+"The set of all singleton classes is itself a class:"
+{ $subsection singleton-class? }
+{ $subsection singleton-class } ;
HELP: SINGLETON:
-{ $syntax "SINGLETON: class"
-} { $values
+{ $syntax "SINGLETON: class" }
+{ $values
{ "class" "a new singleton to define" }
-} { $description
- "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
-} { $examples
+}
+{ $description
+ "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
+}
+{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
-} { $see-also
- POSTPONE: PREDICATE:
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
- "Defines a newly created word to be a singleton class." } ;
+ "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
+HELP: singleton-class
+{ $class-description "The class of singleton classes." } ;
+
ABOUT: "singletons"
generic.standard sequences definitions compiler.units ;
IN: classes.tuple
-ARTICLE: "tuple-constructors" "Constructors"
-"Tuples are created by calling one of two words:"
-{ $subsection construct-empty }
-{ $subsection construct-boa }
-"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>" } "."
+ARTICLE: "parametrized-constructors" "Parameterized constructors"
+"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
$nl
+"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car new"
+ " V{ } clone >>occupants"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane new"
+ " V{ } clone >>occupants"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ ": new-vehicle ( class -- vehicle )"
+ " new"
+ " V{ } clone >>occupants ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car new-vehicle"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane new-vehicle"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
+
+ARTICLE: "tuple-constructors" "Tuple constructors"
+"Tuples are created by calling one of two constructor primitives:"
+{ $subsection new }
+{ $subsection boa }
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
+"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
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+$nl
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
""
+ "! The following two are equivalent"
"C: <rgba> rgba"
- ": <rgba> color construct-boa ; ! identical to above"
+ ": <rgba> color boa ;"
""
+ "! We can define constructors which call other constructors"
": <rgb> f <rgba> ;"
""
- ": <color> construct-empty ;"
- ": <color> f f f f <rgba> ; ! identical to above"
+ "! The following two are equivalent"
+ ": <color> color new ;"
+ ": <color> f f f f <rgba> ;"
+}
+{ $subsection "parametrized-constructors" } ;
+
+ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
+"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
+{ $list
+ "Computing the area"
+ "Computing the perimiter"
+}
+"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
+{ $code
+ "GENERIC: area ( shape -- n )"
+ "GENERIC: perimiter ( shape -- n )"
+ ""
+ "TUPLE: shape ;"
+ ""
+ "TUPLE: circle < shape radius ;"
+ "M: area circle radius>> sq pi * ;"
+ "M: perimiter circle radius>> 2 * pi * ;"
+ ""
+ "TUPLE: quad < shape width height"
+ "M: area quad [ width>> ] [ height>> ] bi * ;"
+ ""
+ "TUPLE: rectangle < quad ;"
+ "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
+ ""
+ ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
+ ""
+ "TUPLE: parallelogram < quad skew ;"
+ "M: parallelogram perimiter"
+ " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ;
-ARTICLE: "tuple-delegation" "Tuple delegation"
-"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
-{ $subsection delegate }
-{ $subsection set-delegate }
-"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
+ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
+"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
+{ $heading "Anti-pattern #1: subclassing for has-a" }
+"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
$nl
-"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
+"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
+{ $code
+ "TUPLE: color r g b ;"
+ "TUPLE: shape < color ... ;"
+}
+"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
+{ $code
+ "TUPLE: rgb-color r g b ;"
+ "TUPLE: hsv-color h s v ;"
+ "..."
+ "TUPLE: shape color ... ;"
+}
+"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
+{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
+"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl
-"A pair of words examine delegation chains:"
-{ $subsection delegates }
-{ $subsection is? }
-"An example:"
-{ $example
- "TUPLE: ellipse center radius ;"
- "TUPLE: colored color ;"
- "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
- "{ 1 0 0 } <colored> \"my-shape\" set"
- "\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup color>> swap center>> .s"
- "{ 0 0 }\n{ 1 0 0 }"
-} ;
+"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
+$nl
+"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
+{ $heading "Anti-pattern #3: subclassing to override a method definition" }
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
+{ $see-also "parametrized-constructors" } ;
+
+ARTICLE: "tuple-subclassing" "Tuple subclassing"
+"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
+$nl
+"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
+{ $code
+ "TUPLE: subclass < superclass ... ;"
+}
+{ $subsection "tuple-inheritance-example" }
+{ $subsection "tuple-inheritance-anti-example" }
+{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
- " employee construct-empty ;" }
+ " employee new ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
- " employee construct-empty"
+ " employee new"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
- " 40000 employee construct-boa ;"
+ " 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
- " checks counter check construct-boa ;"
+ " checks counter check boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
-} ;
+}
+"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
+
+ARTICLE: "tuple-redefinition" "Tuple redefinition"
+"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
+$nl
+"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
+$nl
+"There are three ways to change the list of effective slots of a class:"
+{ $list
+ "Adding or removing direct slots of the class"
+ "Adding or removing direct slots of a superclass of the class"
+ "Changing the inheritance hierarchy by redefining a class to have a different superclass"
+}
+"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
+{ $list
+ "If any slots were removed, the values are removed from the instance and are lost forever."
+ { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
+ "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
+ "If the number or order of effective slots changes, any BOA constructors are recompiled."
+}
+"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
-"Further topics:"
-{ $subsection "tuple-delegation" }
+"Expressing relationships through the object system:"
+{ $subsection "tuple-subclassing" }
+"Introspection:"
{ $subsection "tuple-introspection" }
+"Tuple classes can be redefined; this updates existing instances:"
+{ $subsection "tuple-redefinition" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"
-HELP: delegate
-{ $values { "obj" object } { "delegate" object } }
-{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
-{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
-
-HELP: set-delegate
-{ $values { "delegate" object } { "tuple" tuple } }
-{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
-
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
HELP: define-tuple-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
+{ $values { "class" tuple-class } }
{ $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ;
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
-HELP: delegates
-{ $values { "obj" object } { "seq" sequence } }
-{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
-
-HELP: is?
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
-$nl
-"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
-
HELP: >tuple
{ $values { "seq" sequence } { "tuple" tuple } }
-{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
+{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
-{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
+{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
-HELP: construct-empty
+HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
"TUPLE: employee number name department ;"
- "employee construct-empty ."
+ "employee new ."
"T{ employee f f f f }"
}
} ;
" color construct ;"
}
"The last definition is actually equivalent to the following:"
- { $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
+ { $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
"Which can be abbreviated further:"
{ $code "C: <rgba> color" }
} ;
-HELP: construct-boa
+HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
-{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
+{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
-: <rect> rect construct-boa ;
+: <rect> rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
-GENERIC: delegation-test
-M: object delegation-test drop 3 ;
-TUPLE: quux-tuple ;
-: <quux-tuple> quux-tuple construct-empty ;
-M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple ;
-: <quuux-tuple> { set-delegate } quuux-tuple construct ;
-
-[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
-
-GENERIC: delegation-test-2
-TUPLE: quux-tuple-2 ;
-: <quux-tuple-2> quux-tuple-2 construct-empty ;
-M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 ;
-: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
-
-[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
-
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
[ t ] [ <empty> hashcode fixnum? ] unit-test
-TUPLE: delegate-clone ;
-
-[ T{ delegate-clone T{ empty f } } ]
-[ T{ delegate-clone T{ empty f } } clone ] unit-test
-
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
] unit-test
! Missing check
-[ not-a-tuple-class construct-boa ] must-fail
-[ not-a-tuple-class construct-empty ] must-fail
+[ not-a-tuple-class boa ] must-fail
+[ not-a-tuple-class new ] must-fail
TUPLE: erg's-reshape-problem a b c d ;
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem construct-empty ;
-: cons-test-2 \ erg's-reshape-problem construct-boa ;
+: cons-test-1 \ erg's-reshape-problem new ;
+: cons-test-2 \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ no-tuple-class? ] is? ] must-fail-with
+] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test
+
+! Shadowing test
+[ f ] [
+ t parser-notes? [
+ [
+ "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+ ] with-string-writer empty?
+ ] with-variable
+] unit-test
+
+! Missing error check
+[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
compiler.units math.private accessors assocs ;
IN: classes.tuple
-M: tuple delegate 2 slot ;
-
-M: tuple set-delegate 2 set-slot ;
-
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
>r copy-tuple-slots r>
layout-class prefix ;
-: tuple-slots ( tuple -- array )
+: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
-: >tuple ( tuple -- array )
+: >tuple ( tuple -- seq )
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop ;
+ "slot-names" word-prop
+ [ dup array? [ second ] when ] map ;
+
+: all-slot-names ( class -- slots )
+ superclasses [ slot-names ] map concat \ class prefix ;
+
+ERROR: bad-superclass class ;
<PRIVATE
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- )
- dup dup slot-names generate-tuple-slots
+ dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new
[ define-slots ] ! old
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class prefix ;
-
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
2drop
[
[ update-tuples-after ]
- [ changed-word ]
+ [ changed-definition ]
[ redefined ]
tri
] each-subclass
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+: valid-superclass? ( class -- ? )
+ [ tuple-class? ] [ tuple eq? ] bi or ;
+
+: check-superclass ( superclass -- )
+ dup valid-superclass? [ bad-superclass ] unless drop ;
+
PRIVATE>
GENERIC# define-tuple-class 2 ( class superclass slots -- )
M: word define-tuple-class
+ over check-superclass
define-new-tuple-class ;
M: tuple-class define-tuple-class
3dup tuple-class-unchanged?
- [ 3dup redefine-tuple-class ] unless
+ [ over check-superclass 3dup redefine-tuple-class ] unless
3drop ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi
- dup [ construct-boa throw ] curry define ;
+ dup [ boa throw ] curry define ;
M: tuple-class reset-class
[
M: tuple hashcode*
[
- dup tuple-size -rot 0 -rot [
- swapd array-nth hashcode* bitxor
- ] 2curry reduce
+ [ class hashcode ] [ tuple-size ] [ ] tri
+ >r rot r> [
+ swapd array-nth hashcode* sequence-hashcode-step
+ ] 2curry each
] recursive-hashcode ;
! Deprecated
{ $subsection members }
"The set of union classes is a class:"
{ $subsection union-class }
-{ $subsection union-class? } ;
+{ $subsection union-class? }
+"Unions are used to define behavior shared between a fixed set of classes."
+{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
HELP: cond
-{ $values { "assoc" "a sequence of quotation pairs" } }
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
{ $description
- "Calls the second quotation in the first pair whose first quotation yields a true value."
+ "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
$nl
"The following two phrases are equivalent:"
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
"{"
" { [ dup 0 > ] [ \"positive\" ] }"
" { [ dup 0 < ] [ \"negative\" ] }"
- " { [ dup zero? ] [ \"zero\" ] }"
+ " [ \"zero\" ]"
"} cond"
}
} ;
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
HELP: case
-{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
+{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
{ $description
- "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
+ "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
$nl
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
$nl
-IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint
-namespaces combinators words ;
+namespaces combinators words classes sequences ;
+IN: combinators.tests
+
+! Compiled
+: cond-test-1 ( obj -- str )
+ {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond ;
+
+\ cond-test-1 must-infer
+
+[ "even" ] [ 2 cond-test-1 ] unit-test
+[ "odd" ] [ 3 cond-test-1 ] unit-test
+
+: cond-test-2 ( obj -- str )
+ {
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ [ drop "something else" ]
+ } cond ;
+
+\ cond-test-2 must-infer
+
+[ "true" ] [ t cond-test-2 ] unit-test
+[ "false" ] [ f cond-test-2 ] unit-test
+[ "something else" ] [ "ohio" cond-test-2 ] unit-test
+
+: cond-test-3 ( obj -- str )
+ {
+ [ drop "something else" ]
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ } cond ;
+
+\ cond-test-3 must-infer
+
+[ "something else" ] [ t cond-test-3 ] unit-test
+[ "something else" ] [ f cond-test-3 ] unit-test
+[ "something else" ] [ "ohio" cond-test-3 ] unit-test
+
+: cond-test-4 ( -- )
+ {
+ } cond ;
+
+\ cond-test-4 must-infer
+
+[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
+! Interpreted
[ "even" ] [
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
-: case-test-1
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+! Compiled
+: case-test-1 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
{ 4 [ "four" ] }
} case ;
+\ case-test-1 must-infer
+
[ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted
[ "x" case-test-1 ] must-fail
-: case-test-2
+: case-test-2 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-2 must-infer
+
[ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
-: case-test-3
+: case-test-3 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-3 must-infer
+
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
+: case-const-1 1 ;
+: case-const-2 2 ; inline
+
+! Compiled
+: case-test-4 ( obj -- str )
+ {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case ;
+
+\ case-test-4 must-infer
+
+[ "uno" ] [ 1 case-test-4 ] unit-test
+[ "dos" ] [ 2 case-test-4 ] unit-test
+[ "tres" ] [ 3 case-test-4 ] unit-test
+[ "demasiado" ] [ 100 case-test-4 ] unit-test
+
+: case-test-5 ( obj -- )
+ {
+ { case-const-1 [ "uno" print ] }
+ { case-const-2 [ "dos" print ] }
+ { 3 [ "tres" print ] }
+ { 4 [ "cuatro" print ] }
+ { 5 [ "cinco" print ] }
+ [ drop "demasiado" print ]
+ } case ;
+
+\ case-test-5 must-infer
+
+[ ] [ 1 case-test-5 ] unit-test
+
+! Interpreted
+[ "uno" ] [
+ 1 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "dos" ] [
+ 2 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "tres" ] [
+ 3 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "demasiado" ] [
+ 100 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+: do-not-call "do not call" throw ;
+
+: test-case-6
+ {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case ;
+
+[ "three" ] [ 3 test-case-6 ] unit-test
+[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
+
+[ "three" ] [
+ 3 {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ [ do-not-call ] first {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ \ do-not-call {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
-hashtables sorting ;
+hashtables sorting words sets ;
: cleave ( x seq -- )
[ call ] with each ;
ERROR: no-cond ;
: cond ( assoc -- )
- [ first call ] find nip dup [ second call ] [ no-cond ] if ;
+ [ dup callable? [ drop t ] [ first call ] if ] find nip
+ [ dup callable? [ call ] [ second call ] if ]
+ [ no-cond ] if* ;
ERROR: no-case ;
+: case-find ( obj assoc -- obj' )
+ [
+ dup array? [
+ dupd first dup word? [
+ execute
+ ] [
+ dup wrapper? [ wrapped ] when
+ ] if =
+ ] [ quotation? ] if
+ ] find nip ;
: case ( obj assoc -- )
- [ dup array? [ dupd first = ] [ quotation? ] if ] find nip
- {
+ case-find {
{ [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ no-case ] }
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
+ [ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
- [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
- alist>quot ;
+ [
+ [ 1quotation \ dup prefix \ = suffix ]
+ [ \ drop prefix ] bi*
+ ] assoc-map alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
dup empty? [
drop
] [
- dup length 4 <= [
+ dup length 4 <=
+ over keys [ word? ] contains? or
+ [
linear-case-quot
] [
dup keys contiguous-range? [
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
- { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
- { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
- { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
+ { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
+ { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
+ { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
+ { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
-inference.state generator debugger math.parser prettyprint words
-compiler.units continuations vocabs assocs alien.compiler dlists
-optimizer definitions math compiler.errors threads graphs
-generic inference ;
+inference.state generator debugger words compiler.units
+continuations vocabs assocs alien.compiler dlists optimizer
+definitions math compiler.errors threads graphs generic
+inference ;
IN: compiler
: ripple-up ( word -- )
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
- over crossref? [ compiled-xref ] [ 2drop ] if ;
+ over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
-[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
+[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+[ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
} cond
] compile-call
] unit-test
[
3 {
{ [ dup fixnum? ] [ ] }
- { [ t ] [ drop t ] }
+ [ drop t ]
} cond
] compile-call
] unit-test
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units ;
+words kernel math effects definitions compiler.units accessors ;
-: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
[ ] [ compute-free-vregs ] unit-test
- [ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
- 1 <int-vreg> T{ int-regs } free-vregs member?
+ 1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
- [ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
] unit-test
[ ] [
- 2 phantom-d get phantom-input
+ 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
- phantom-d get [ cached? ] all?
+ phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
IN: compiler.tests
! Oops!
] [ 2drop no-case ] if
] compile-call
] unit-test
+
+: float-spill-bug
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+ { tuple vector } 3 slot { word } declare
+ dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test
TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ]
-[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
+[ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [
- 1 2 3 color construct-boa
+ 1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
10 20
- 1 2 3 color construct-boa [
+ 1 2 3 color boa [
[
{ set-color-red set-color-blue } set-slots
] compile-call
] unit-test
[ T{ color f f f f } ]
-[ [ color construct-empty ] compile-call ] unit-test
-
-[ T{ color "a" f "b" f } ] [
- "a" "b"
- [ { set-delegate set-color-green } color construct ]
- compile-call
-] unit-test
-
-[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test
+[ [ color new ] compile-call ] unit-test
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
- \ redefine-error construct-boa
+ \ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
[ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
-: changed-definitions ( -- assoc )
+: updated-definitions ( -- assoc )
H{ } clone
dup forgotten-definitions get update
dup new-definitions get first update
dup new-definitions get second update
- dup changed-words get update
+ dup changed-definitions get update
dup dup changed-vocabs update ;
: compile ( words -- )
recompile-hook get call
- dup [ drop crossref? ] assoc-contains?
+ dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-words get keys
+ changed-definitions get keys [ word? ] subset
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
- dup [ drop crossref? ] assoc-contains? modify-code-heap
- changed-definitions notify-definition-observers ;
+ dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
+ updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
- H{ } clone changed-words set
+ H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
<definitions> new-definitions set
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+assocs words quotations io ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
{ $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+{ $heading "Anti-pattern #1: Ignoring errors" }
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+{ $heading "Anti-pattern #2: Catching errors too early" }
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+$nl
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
+{ $heading "Anti-pattern #5: Leaking external resources" }
+"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
+{ $code
+ "<external-resource> ... do stuff ... dispose"
+}
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
{ $subsection cleanup }
{ $subsection recover }
{ $subsection ignore-errors }
+"Syntax sugar for defining errors:"
+{ $subsection POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
+{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
-"Continuations serve as the building block for a number of higher-level abstractions."
-{ $subsection "errors" }
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
ABOUT: "continuations"
HELP: dispose
{ $values { "object" "a disposable object" } }
-{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
+{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
+$nl
+"No further operations can be performed on a disposable object after this call."
+$nl
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
HELP: with-disposal
! Weird PowerPC bug.
[ ] [
[ "4" throw ] ignore-errors
- data-gc
- data-gc
+ gc
+ gc
] unit-test
[ f ] [ { } kernel-error? ] unit-test
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
-TUPLE: condition restarts continuation ;
+TUPLE: condition error restarts continuation ;
-: <condition> ( error restarts cc -- condition )
- {
- set-delegate
- set-condition-restarts
- set-condition-continuation
- } condition construct ;
+C: <condition> condition ( error restarts cc -- condition )
: throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ;
C: <restart> restart
: restart ( restart -- )
- dup restart-obj swap restart-continuation continue-with ;
+ [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
-M: tuple compute-restarts delegate compute-restarts ;
-
M: condition compute-restarts
- [ delegate compute-restarts ] keep
- [ condition-restarts ] keep
- condition-continuation
- [ <restart> ] curry { } assoc>map
- append ;
+ [ error>> compute-restarts ]
+ [
+ [ restarts>> ]
+ [ condition-continuation [ <restart> ] curry ] bi
+ { } assoc>map
+ ] bi append ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
-byte-arrays bit-arrays float-arrays combinators words ;
+byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
+SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch cpu ( -- )
M: ppc %jump-label ( label -- ) B ;
-M: ppc %jump-t ( label -- )
- 0 "flag" operand f v>operand CMPI BNE ;
+M: ppc %jump-f ( label -- )
+ 0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- )
[
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+GENERIC: STF ( src dst off reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+
+M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+GENERIC: LF ( dst src off reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+
+M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
2array define-if-intrinsics ;
{
- { fixnum< BLT }
- { fixnum<= BLE }
- { fixnum> BGT }
- { fixnum>= BGE }
- { eq? BEQ }
+ { fixnum< BGE }
+ { fixnum<= BGT }
+ { fixnum> BLE }
+ { fixnum>= BLT }
+ { eq? BNE }
} [
first2 define-fixnum-jump
] each
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< BLT }
- { float<= BLE }
- { float> BGT }
- { float>= BGE }
- { float= BEQ }
+ { float< BGE }
+ { float<= BGT }
+ { float> BLE }
+ { float>= BLT }
+ { float= BNE }
} [
first2 define-float-jump
] each
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 xt-reg ECX ;
M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ;
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
- T{ int-regs } box@
+ int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
- } {
- [ t ] [ drop ]
}
+ [ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
- JNE
+ JE
] { } define-if-intrinsic
"-no-sse2" cli-args member? [
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 xt-reg RCX ;
M: x86.64 stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ;
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- )
- T{ int-regs } swap %unbox ;
+ int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
- T{ int-regs } swap %box ;
+ int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
- T{ int-regs } swap member?
+ int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: stack-reg cpu
-HOOK: xt-reg cpu
HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
-: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+
+M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
3 cells + 16 align cell - ;
M: x86 %save-word-xt ( -- )
- xt-reg 0 MOV rc-absolute-cell rel-this ;
+ temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
- xt-reg PUSH
+ temp-reg v>operand PUSH
stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- )
M: x86 %jump-label ( label -- ) JMP ;
-M: x86 %jump-t ( label -- )
- "flag" operand f v>operand CMP JNE ;
+M: x86 %jump-f ( label -- )
+ "flag" operand f v>operand CMP JE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect construct-boa dup canonicalize ;
+ indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ;
{
{ [ dup register-128? ] [ drop operand-64? ] }
{ [ dup not ] [ drop operand-64? ] }
- { [ t ] [ nip operand-64? ] }
+ [ nip operand-64? ]
} cond and ;
: rex.r
2array define-if-intrinsics ;
{
- { fixnum< JL }
- { fixnum<= JLE }
- { fixnum> JG }
- { fixnum>= JGE }
- { eq? JE }
+ { fixnum< JGE }
+ { fixnum<= JG }
+ { fixnum> JLE }
+ { fixnum>= JL }
+ { eq? JNE }
} [
first2 define-fixnum-jump
] each
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< JB }
- { float<= JBE }
- { float> JA }
- { float>= JAE }
- { float= JE }
+ { float< JAE }
+ { float<= JA }
+ { float> JBE }
+ { float>= JB }
+ { float= JNE }
} [
first2 define-float-jump
] each
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs threads threads.private init
-kernel.private libc io.encodings ;
+generic.math io.streams.duplex classes.builtin classes
+compiler.units generic.standard vocabs threads threads.private
+init kernel.private libc io.encodings accessors ;
IN: debugger
GENERIC: error. ( error -- )
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- { [ t ] [ second 0 15 between? ] }
+ [ second 0 15 between? ]
} cond ;
: kernel-errors
M: no-math-method summary
drop "No suitable arithmetic method" ;
+M: no-next-method summary
+ drop "Executing call-next-method from least-specific method" ;
+
+M: inconsistent-next-method summary
+ drop "Executing call-next-method with inconsistent parameters" ;
+
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
drop "Invalid parameters for create-method" ;
M: no-tuple-class summary
- drop "Invalid class for define-constructor" ;
+ drop "BOA constructors can only be defined for tuple classes" ;
+
+M: bad-superclass summary
+ drop "Tuple classes can only inherit from other tuple classes" ;
M: no-cond summary
drop "Fall-through in cond" ;
M: bounds-error summary drop "Sequence index out of bounds" ;
-M: condition error. delegate error. ;
+M: condition error. error>> error. ;
+
+M: condition summary error>> summary ;
-M: condition error-help drop f ;
+M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
{ $subsection forget }
"Definitions can answer a sequence of definitions they directly depend on:"
{ $subsection uses }
-"When a definition is changed, all definitions which depend on it are notified via a hook:"
-{ $subsection redefined* }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* }
{ $subsection definer }
{ $description "Outputs a sequence of definitions that directly call the given definition." }
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-HELP: redefined*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Updates the definition to cope with a callee being redefined." }
-$low-level-note ;
-
HELP: unxref
{ $values { "defspec" "a definition specifier" } }
{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
USING: tools.test generic kernel definitions sequences
compiler.units words ;
-TUPLE: combination-1 ;
-
-M: combination-1 perform-combination drop [ ] define ;
-
-M: combination-1 make-default-method 2drop [ "No method" throw ] ;
-
-SYMBOL: generic-1
-
-[
- generic-1 T{ combination-1 } define-generic
-
- object \ generic-1 create-method [ ] define
-] with-compilation-unit
-
-[ ] [
- [
- { combination-1 { object generic-1 } } forget-all
- ] with-compilation-unit
-] unit-test
-
GENERIC: some-generic ( a -- b )
USE: arrays
ERROR: no-compilation-unit definition ;
+SYMBOL: changed-definitions
+
+: changed-definition ( defspec -- )
+ dup changed-definitions get
+ [ no-compilation-unit ] unless*
+ set-at ;
+
GENERIC: where ( defspec -- loc )
M: object where drop f ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
-GENERIC: redefined* ( defspec -- )
-
-M: object redefined* drop ;
-
-: redefined ( defspec -- )
- [ crossref get at ] closure [ drop redefined* ] assoc-each ;
-
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;
USING: dlists dlists.private kernel tools.test random assocs
-hashtables sequences namespaces sorting debugger io prettyprint
+sets sequences namespaces sorting debugger io prettyprint
math ;
IN: dlists.tests
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
- ] 2keep seq-diff assert-same-elements
+ ] 2keep diff assert-same-elements
] unit-test
[ ] [
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
- dlist construct-empty
+ dlist new
0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ;
{
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
- { [ t ] [ unlink-node dec-length ] }
+ [ unlink-node dec-length ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
- effect construct-boa ;
+ effect boa ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;
{ [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
- { [ t ] [ t ] }
+ [ t ]
} cond 2nip ;
GENERIC: (stack-picture) ( obj -- str )
M: float-array like
drop dup float-array? [ >float-array ] unless ;
-M: float-array new drop 0.0 <float-array> ;
+M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: float-array>vector ( float-array length -- float-vector )\r
- float-vector construct-boa ; inline\r
+ float-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length float-array>vector ] [ >float-vector ] if\r
] unless ;\r
\r
-M: float-vector new\r
+M: float-vector new-sequence\r
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
\r
M: float-vector equal?\r
--- /dev/null
+Growable float arrays
--- /dev/null
+collections
TUPLE: frame-required n ;
-: frame-required ( n -- ) \ frame-required construct-boa , ;
+: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
TUPLE: label offset ;
-: <label> ( -- label ) label construct-empty ;
+: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset swap set-label-offset ;
M: word fixup*
{
- { %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
TUPLE: label-fixup label class ;
-: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
+: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup label-fixup-class rc-absolute?
TUPLE: rel-fixup arg class type ;
-: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? -
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
- { [ t ] [ dup compile-queue get set-at ] }
+ [ dup compile-queue get set-at ]
} cond ;
: maybe-compile ( word -- )
: generate-if ( node label -- next )
<label> [
- >r >r node-children first2 generate-branch
+ >r >r node-children first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
- [ <label> dup %jump-t ]
+ [ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
- "true" define-label
+ "false" define-label
"end" define-label
- "true" get swap call
- f "if-scratch" get load-literal
- "end" get %jump-label
- "true" resolve-label
+ "false" get swap call
t "if-scratch" get load-literal
+ "end" get %jump-label
+ "false" resolve-label
+ f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
- { { f "if-scratch" } } +scratch+ associate union
+ { { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
-words effects alien byte-arrays bit-arrays float-arrays ;
+words effects alien byte-arrays bit-arrays float-arrays
+accessors sets ;
IN: generator.registers
SYMBOL: +input+
SYMBOL: known-tag
! Register classes
-TUPLE: int-regs ;
-
-TUPLE: float-regs size ;
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
<PRIVATE
M: value lazy-store 2drop ;
! A scratch register for computations
-TUPLE: vreg n ;
+TUPLE: vreg n reg-class ;
-: <vreg> ( n reg-class -- vreg )
- { set-vreg-n set-delegate } vreg construct ;
+C: <vreg> vreg ( n reg-class -- vreg )
-M: vreg v>operand dup vreg-n swap vregs nth ;
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
-TUPLE: temp-reg ;
-
-: temp-reg T{ temp-reg T{ int-regs } } ;
+SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> { set-ds-loc-n } ds-loc construct ;
+: <ds-loc> f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> { set-rs-loc-n } rs-loc construct ;
-
+: <rs-loc> f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
- { set-tagged-vreg } tagged construct ;
+ f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
- { [ t ] [ drop %unbox-any-c-ptr ] }
+ [ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
} case ;
! A compile-time stack
-TUPLE: phantom-stack height ;
+TUPLE: phantom-stack height stack ;
-GENERIC: finalize-height ( stack -- )
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
-SYMBOL: phantom-d
-SYMBOL: phantom-r
+GENERIC: finalize-height ( stack -- )
-: <phantom-stack> ( class -- stack )
- >r
- V{ } clone 0
- { set-delegate set-phantom-stack-height }
- phantom-stack construct
- r> construct-delegate ;
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
: (loc)
#! Utility for methods on <loc>
- phantom-stack-height - ;
+ height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
- swap [
- phantom-stack-height
- dup zero? [ 2drop ] [ swap execute ] if
- 0
- ] keep set-phantom-stack-height ; inline
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
-TUPLE: phantom-datastack ;
+TUPLE: phantom-datastack < phantom-stack ;
-: <phantom-datastack> phantom-datastack <phantom-stack> ;
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
-TUPLE: phantom-retainstack ;
+TUPLE: phantom-retainstack < phantom-stack ;
-: <phantom-retainstack> phantom-retainstack <phantom-stack> ;
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
- dup length swap phantom-locs ;
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
- >r dup phantom-locs* swap r> 2each ; inline
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
- >r phantom-d get r> phantom-r get over
- >r >r (each-loc) r> r> (each-loc) ; inline
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
- [ phantom-stack-height + ] keep set-phantom-stack-height ;
-
-GENERIC: cut-phantom ( n phantom -- seq )
+ swap [ + ] curry change-height drop ;
-M: phantom-stack cut-phantom
- [ delegate swap cut* swap ] keep set-delegate ;
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
- over length over adjust-phantom push-all ;
+ over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
- 2dup length <= [
+ 2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
- [ length head-slice* ] keep
- [ append >vector ] keep
- delegate set-delegate
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
- [ [ [ live-vregs* ] each ] each-phantom ] { } make ;
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
- dup phantom-locs* swap 2array flip
+ [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
values ;
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
- float eq?
- T{ float-regs f 8 } T{ int-regs } ? ;
+ float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
- dup reg-spec>class free-vregs pop swap {
+ [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
- { [ t ] [ f ] }
+ [ f ]
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
- { [ t ] [ nip reg-spec>class ] }
+ [ nip reg-spec>class ]
} cond ;
: alloc-vreg-for ( value spec -- vreg )
- swap operand-class swap alloc-vreg
- dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
- [ <vreg> ] curry map seq-diff
+ [ <vreg> ] curry map diff
>vector ;
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
- { T{ int-regs } T{ float-regs f 8 } }
+ { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
- dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
- [ swap - <ds-loc> ] curry map 2array flip ;
+ [ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
- T{ int-regs } free-vregs [ length ] bi@ <= ;
+ int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
- over [
+ over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
- over delete-all
- swap push-all ;
+ over stack>> delete-all
+ swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
- T{ float-regs f 8 } free-vregs length <=
- >r T{ int-regs } free-vregs length <= r> and ;
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
+ >r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
- [ substitute-here ] curry each-phantom ;
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
substitute-vregs ;
: load-inputs ( -- )
- +input+ get dup length phantom-d get phantom-input
- swap lazy-load ;
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
- phantoms append [
+ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member?
] with contains? ;
: count-input-vregs ( phantom spec -- )
phantom&spec [
- >r dup cached? [ cached-vreg ] when r> allocation
+ >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
- H{
- { T{ int-regs } 0 }
- { T{ float-regs 8 } 0 }
- } clone [
+ [
+ 0 int-regs set
+ 0 double-float-regs set
count-scratch-regs
- phantom-r get swap count-input-vregs
- phantom-d get swap count-input-vregs
- T{ int-regs } get T{ float-regs 8 } get
- ] bind ;
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
+ int-regs get double-float-regs get
+ ] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
- +output+ get [ get ] map phantom-d get phantom-append ;
+ +output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
2drop t
] if ;
-: class-tags ( class -- tag/f )
- class-types [
- dup num-tags get >=
- [ drop object tag-number ] when
- ] map prune ;
-
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
- phantom-d get +input+ rot at
+ phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
] unless ;
: clear-phantoms ( -- )
- [ delete-all ] each-phantom ;
+ [ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
- phantom-d get
+ phantom-datastack get
over length over add-locs
- [ set-operand-class ] 2reverse-each ;
+ stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
finalize-contents
clear-phantoms
finalize-heights
- fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
- <phantom-datastack> phantom-d set
- <phantom-retainstack> phantom-r set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
- phantom-d [ clone ] change
- phantom-r [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
operand-class immediate class< ;
: phantom-push ( obj -- )
- 1 phantom-d get adjust-phantom
- phantom-d get push ;
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
- [ effect-in length phantom-d get phantom-input ] keep
- shuffle* phantom-d get phantom-append ;
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- )
- phantom-d get phantom-input
- phantom-r get phantom-append ;
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
- phantom-r get phantom-input
- phantom-d get phantom-append ;
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
+"Finding the most specific method for an object:"
+{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
{ $see-also "generic-introspection" } ;
+ARTICLE: "call-next-method" "Calling less-specific methods"
+"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
+$nl
+"Less-specific methods can be called directly:"
+{ $subsection POSTPONE: call-next-method }
+"A lower-level word which the above expands into:"
+{ $subsection (call-next-method) }
+"To look up the next applicable method reflectively:"
+{ $subsection next-method }
+"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
+{ $subsection inconsistent-next-method }
+{ $subsection no-next-method } ;
+
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl
{ $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
+{ $subsection "call-next-method" }
{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes order } related-words
+
+HELP: (call-next-method)
+{ $values { "class" class } { "generic" generic } }
+{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
+{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
[ 3 ] [ T{ first-one } wii ] unit-test
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ;
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+GENERIC: effective-method ( ... generic -- method )
+
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
-GENERIC: next-method-quot ( class generic -- quot )
+GENERIC: next-method-quot* ( class generic -- quot )
+
+: next-method-quot ( class generic -- quot )
+ dup "combination" word-prop next-method-quot* ;
: (call-next-method) ( class generic -- )
next-method-quot call ;
: check-method ( class generic -- class generic )
over class? over generic? and [
- \ check-method construct-boa throw
+ \ check-method boa throw
] unless ; inline
: with-methods ( generic quot -- )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
-sequences.private classes classes.algebra definitions ;
+sequences.private classes classes.builtin classes.algebra
+definitions ;
IN: generic.math
PREDICATE: math-class < class
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
- { [ t ] [ drop { 100 100 } ] }
+ [ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;
+
+GENERIC: extra-values ( generic -- n )
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
- { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+ [ [ first second ] [ 1 tail-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )
-IN: generic.standard.engines.tuple
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations arrays ;
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
- [
- over zero? [
- dup assoc-empty?
- [ drop f ] [ values first ] if
- ] [
- dupd <echelon-dispatch-engine>
- ] if
- ] assoc-map [ nip ] assoc-subset
- \ tuple-dispatch-engine construct-boa ;
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
: convert-tuple-methods ( assoc -- assoc' )
tuple bootstrap-word
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
+: word-hashcode% [ 1 slot ] % ;
+
: class-hash-dispatch-quot ( methods -- quot )
- #! 1 slot == word hashcode
[
- [ dup 1 slot ] %
+ \ dup ,
+ word-hashcode%
hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ;
-: tuple-dispatch-engine-word-name ( engine -- string )
- [
- generic get word-name %
- "/tuple-dispatch-engine/" %
- n>> #
- ] "" make ;
+: engine-word-name ( -- string )
+ generic get word-name "/tuple-dispatch-engine" append ;
-PREDICATE: tuple-dispatch-engine-word < word
- "tuple-dispatch-engine" word-prop ;
+PREDICATE: engine-word < word
+ "tuple-dispatch-generic" word-prop generic? ;
-M: tuple-dispatch-engine-word stack-effect
- "tuple-dispatch-generic" word-prop stack-effect ;
+M: engine-word stack-effect
+ "tuple-dispatch-generic" word-prop
+ [ extra-values ] [ stack-effect ] bi
+ dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: tuple-dispatch-engine-word crossref?
+M: engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
-: <tuple-dispatch-engine-word> ( engine -- word )
- tuple-dispatch-engine-word-name f <word>
- {
- [ t "tuple-dispatch-engine" set-word-prop ]
- [ generic get "tuple-dispatch-generic" set-word-prop ]
- [ remember-engine ]
- [ ]
- } cleave ;
+: <engine-word> ( -- word )
+ engine-word-name f <word>
+ dup generic get "tuple-dispatch-generic" set-word-prop ;
-: define-tuple-dispatch-engine-word ( engine quot -- word )
- >r <tuple-dispatch-engine-word> dup r> define ;
+: define-engine-word ( quot -- word )
+ >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 4 slot { array } declare ; inline
: tuple-dispatch-engine-body ( engine -- quot )
- #! 1 slot == tuple-layout
- #! 2 slot == 0 array-nth
- #! 4 slot == layout-superclasses
[
picker %
- [ 1 slot 4 slot ] %
- [ n>> 2 + , [ slot ] % ]
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [ ] make ;
M: echelon-dispatch-engine engine>quot
- dup tuple-dispatch-engine-body
- define-tuple-dispatch-engine-word
- 1quotation ;
+ dup n>> zero? [
+ methods>> dup assoc-empty?
+ [ drop default get ] [ values first engine>quot ] if
+ ] [
+ [
+ picker %
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make
+ ] if ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ;
+: tuple-layout-echelon ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
M: tuple-dispatch-engine engine>quot
- #! 1 slot == tuple-layout
- #! 5 slot == layout-echelon
[
picker %
- [ 1 slot 5 slot ] %
- echelons>>
+ [ tuple-layout-echelon ] %
[
tuple assumed set
- [ engine>quot dup default set ] assoc-map
+ echelons>> dup empty? [
+ unclip-last
+ [
+ [
+ engine>quot define-engine-word
+ [ remember-engine ] [ 1quotation ] bi
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
+ ] unless
] with-scope
>=-case-quot %
] [ ] make ;
-USING: generic help.markup help.syntax sequences ;
+USING: generic help.markup help.syntax sequences math
+math.parser ;
IN: generic.standard
HELP: no-method
{ $class-description
"Performs standard method combination."
$nl
- "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
+ "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
}
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words
+
+HELP: no-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: number error-test 3 + call-next-method ;"
+ ""
+ "M: integer error-test recip call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
+} ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser namespaces ;
+words float-arrays byte-arrays bit-arrays parser namespaces
+quotations inference vectors growable hashtables sbufs
+prettyprint ;
GENERIC: lo-tag-test
[ salary ] must-infer
-[ 24000 ] [ employee construct-boa salary ] unit-test
+[ 24000 ] [ employee boa salary ] unit-test
-[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+[ 24000 ] [ tape-monkey boa salary ] unit-test
-[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+[ 36000 ] [ junior-manager boa salary ] unit-test
-[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+[ 41000 ] [ middle-manager boa salary ] unit-test
-[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+[ 51000 ] [ senior-manager boa salary ] unit-test
-[ 102000 ] [ executive construct-boa salary ] unit-test
+[ 102000 ] [ executive boa salary ] unit-test
-[ ceo construct-boa salary ]
-[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+[ ceo boa salary ]
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
-[ intern construct-boa salary ]
+[ intern boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with
! Weird shit
T{ a } funky
{ { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: my-tuple-hook my-var ( -- x )
+
+M: sequence my-tuple-hook my-hook ;
+
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
+[ f ] [
+ \ my-tuple-hook [ "engines" word-prop ] keep prefix
+ [ 1quotation infer ] map all-equal?
+] unit-test
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
+
+GENERIC: no-stack-effect-decl
+
+M: hashtable no-stack-effect-decl ;
+M: vector no-stack-effect-decl ;
+M: sbuf no-stack-effect-decl ;
+
+[ ] [ \ no-stack-effect-decl see ] unit-test
+
+[ ] [ \ no-stack-effect-decl word-def . ] unit-test
drop generic get "default-method" word-prop 1quotation
] unless ;
-GENERIC: mangle-method ( method generic -- quot )
+: mangle-method ( method generic -- quot )
+ [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
+ prepend [ ] like ;
: single-combination ( word -- quot )
[
} cleave
] with-scope ;
+ERROR: inconsistent-next-method class generic ;
+
+ERROR: no-next-method class generic ;
+
+: single-next-method-quot ( class generic -- quot )
+ [
+ [ drop [ instance? ] curry % ]
+ [
+ 2dup next-method
+ [ 2nip 1quotation ]
+ [ [ no-next-method ] 2curry ] if* ,
+ ]
+ [ [ inconsistent-next-method ] 2curry , ]
+ 2tri
+ \ if ,
+ ] [ ] make ;
+
+: single-effective-method ( obj word -- method )
+ [ order [ instance? ] with find-last nip ] keep method ;
+
TUPLE: standard-combination # ;
C: <standard-combination> standard-combination
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ; inline
-M: standard-generic mangle-method
- drop 1quotation ;
+M: standard-generic extra-values drop 0 ;
M: standard-combination make-default-method
[ empty-method ] with-standard ;
M: standard-combination dispatch# #>> ;
-ERROR: inconsistent-next-method object class generic ;
-
-ERROR: no-next-method class generic ;
-
-M: standard-generic next-method-quot
+M: standard-combination next-method-quot*
[
- [
- [ [ instance? ] curry ]
- [ dispatch# (picker) ] bi* prepend %
- ]
- [
- 2dup next-method
- [ 2nip 1quotation ]
- [ [ no-next-method ] 2curry ] if* ,
- ]
- [ [ inconsistent-next-method ] 2curry , ]
- 2tri
- \ if ,
- ] [ ] make ;
+ single-next-method-quot picker prepend
+ ] with-standard ;
+
+M: standard-generic effective-method
+ [ dispatch# (picker) call ] keep single-effective-method ;
TUPLE: hook-combination var ;
M: hook-combination dispatch# drop 0 ;
-M: hook-generic mangle-method
- drop 1quotation [ drop ] prepend ;
+M: hook-generic extra-values drop 1 ;
+
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep
+ single-effective-method ;
M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
+M: hook-combination next-method-quot*
+ [ single-next-method-quot ] with-hook ;
+
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate }
-{ $subsection ?set-at }
-"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
-{ $subsection prune }
-"Test if a sequence contains duplicates in linear time:"
-{ $subsection all-unique? } ;
+{ $subsection ?set-at } ;
ABOUT: "hashtables"
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;
-HELP: prune
-{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
-{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
-} ;
-
-HELP: all-unique?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests whether a sequence contains any repeated elements." }
-{ $example
- "USING: hashtables prettyprint ;"
- "{ 0 1 1 2 3 5 } all-unique? ."
- "f"
-} ;
-
HELP: rehash
{ $values { "hash" hashtable } }
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
-
-[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
-[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
PRIVATE>
: <hashtable> ( n -- hash )
- hashtable construct-empty [ reset-hash ] keep ;
+ hashtable new [ reset-hash ] keep ;
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
-: (prune) ( hash vec elt -- )
- rot 2dup key?
- [ 3drop ] [ dupd dupd set-at swap push ] if ; inline
-
-: prune ( seq -- newseq )
- [ length <hashtable> ]
- [ length <vector> ]
- [ ] tri
- [ >r 2dup r> (prune) ] each nip ;
-
-: all-unique? ( seq -- ? )
- [ length ]
- [ prune length ] bi = ;
-
INSTANCE: hashtable assoc
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
-heaps heaps.private math.parser random assocs sequences sorting ;
+heaps heaps.private math.parser random assocs sequences sorting
+accessors ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- heap-data dup length swap [ entry-index ] map sequence= ;
+ data>> dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
[
random-alist
<min-heap> [ heap-push-all ] keep
- dup heap-data clone swap
+ dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
- heap-data
+ data>>
[ [ entry-key ] map ] bi@
[ natural-sort ] bi@ ;
<PRIVATE
-: heap-data delegate ; inline
+TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> construct-delegate ; inline
+ >r V{ } clone r> boa ; inline
TUPLE: entry value key heap index ;
-: <entry> ( value key heap -- entry ) f entry construct-boa ;
+: <entry> ( value key heap -- entry ) f entry boa ;
PRIVATE>
-TUPLE: min-heap ;
+TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ;
-TUPLE: max-heap ;
+TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
- heap-data empty? ;
+ data>> empty? ;
M: priority-queue heap-size ( heap -- n )
- heap-data length ;
+ data>> length ;
<PRIVATE
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
- heap-data nth-unsafe ; inline
+ data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
- heap-data set-nth-unsafe ;
+ data>> set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
- swap 2dup heap-data ensure 2drop data-set-nth
+ swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
- heap-data pop ; inline
+ data>> pop ; inline
: data-pop* ( heap -- )
- heap-data pop* ; inline
+ data>> pop* ; inline
: data-peek ( heap -- entry )
- heap-data peek ; inline
+ data>> peek ; inline
: data-first ( heap -- entry )
- heap-data first ; inline
+ data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
--- /dev/null
+collections
USING: help.syntax help.markup words effects inference.dataflow
-inference.state inference.backend kernel sequences
+inference.state kernel sequences
kernel.private combinators sequences.private ;
+IN: inference.backend
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
-{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
+{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple ;
+generic.standard.engines.tuple accessors ;
IN: inference.backend
: recursive-label ( word -- label/f )
M: method-body inline?
"method-generic" word-prop inline? ;
-M: tuple-dispatch-engine-word inline?
+M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
-TUPLE: inference-error rstate type ;
+TUPLE: inference-error error type rstate ;
-M: inference-error compiler-error-type
- inference-error-type ;
+M: inference-error compiler-error-type type>> ;
+
+M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
- >r construct-boa r>
- recursive-state get {
- set-delegate
- set-inference-error-type
- set-inference-error-rstate
- } \ inference-error construct throw ; inline
+ >r boa r>
+ recursive-state get
+ \ inference-error boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
TUPLE: too-many-r> ;
-: check-r> ( -- )
- meta-r get empty?
+: check-r> ( n -- )
+ meta-r get length >
[ \ too-many-r> inference-error ] when ;
-: infer->r ( -- )
- 1 ensure-values
+: infer->r ( n -- )
+ dup ensure-values
#>r
- 1 0 pick node-inputs
- pop-d push-r
- 0 1 pick node-outputs
- node, ;
+ over 0 pick node-inputs
+ over [ drop pop-d ] map reverse [ push-r ] each
+ 0 pick pick node-outputs
+ node,
+ drop ;
-: infer-r> ( -- )
- check-r>
+: infer-r> ( n -- )
+ dup check-r>
#r>
- 0 1 pick node-inputs
- pop-r push-d
- 1 0 pick node-outputs
- node, ;
+ 0 pick pick node-inputs
+ over [ drop pop-r ] map reverse [ push-d ] each
+ over 0 pick node-outputs
+ node,
+ drop ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
dup infer-uncurry
constructor [
peek-d reify-curry
- infer->r
+ 1 infer->r
peek-d reify-curry
- infer-r>
+ 1 infer-r>
2 1 <effect> swap #call consume/produce
] when* ;
: reify-curries ( n -- )
meta-d get reverse [
dup special? [
- over [ infer->r ] times
+ over infer->r
dup reify-curry
- over [ infer-r> ] times
+ over infer-r>
] when 2drop
] 2each ;
{ [ dup [ curried? ] all? ] [ unify-curries ] }
{ [ dup [ composed? ] all? ] [ unify-composed ] }
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
- { [ t ] [ drop <computed> ] }
+ [ drop <computed> ]
} cond ;
: unify-stacks ( seq -- stack )
\ effect-error inference-error ;
: check-effect ( word effect -- )
- dup pick "declared-effect" word-prop effect<=
+ dup pick stack-effect effect<=
[ 2drop ] [ effect-error ] if ;
: finish-word ( word -- )
{ [ dup "infer" word-prop ] [ custom-infer ] }
{ [ dup "no-effect" word-prop ] [ no-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ t ] [ dup infer-word make-call-node ] }
+ [ dup infer-word make-call-node ]
} cond ;
TUPLE: recursive-declare-error word ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
-inference.state ;
+inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
- <computed> recursive-state get value construct-boa ;
+ <computed> recursive-state get value boa ;
M: value hashcode* nip value-uid ;
GENERIC: flatten-curry ( value -- )
M: curried flatten-curry
- dup curried-obj flatten-curry
- curried-quot flatten-curry ;
+ [ obj>> flatten-curry ]
+ [ quot>> flatten-curry ] bi ;
M: composed flatten-curry
- dup composed-quot1 flatten-curry
- composed-quot2 flatten-curry ;
+ [ quot1>> flatten-curry ]
+ [ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ;
meta-d get clone flatten-curries ;
: modify-values ( node quot -- )
- [ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
- [ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
- [ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
- swap [ node-out-r swap call ] keep set-node-out-r ; inline
+ {
+ [ change-in-d ]
+ [ change-in-r ]
+ [ change-out-d ]
+ [ change-out-r ]
+ } cleave drop ; inline
: node-shuffle ( node -- shuffle )
- dup node-in-d swap node-out-d <effect> ;
-
-: make-node ( slots class -- node )
- >r node construct r> construct-delegate ; inline
-
-: empty-node ( class -- node )
- { } swap make-node ; inline
+ [ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
- { set-node-param } swap make-node ; inline
+ new swap >>param ; inline
: in-node ( seq class -- node )
- { set-node-in-d } swap make-node ; inline
+ new swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
- { set-node-out-d } swap make-node ; inline
+ new swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
: node-child node-children first ;
-TUPLE: #label word loop? ;
+TUPLE: #label < node word loop? ;
: #label ( word label -- node )
- \ #label param-node [ set-#label-word ] keep ;
+ \ #label param-node swap >>word ;
PREDICATE: #loop < #label #label-loop? ;
-TUPLE: #entry ;
+TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ;
-TUPLE: #call ;
+TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ;
-TUPLE: #call-label ;
+TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ;
-TUPLE: #push ;
+TUPLE: #push < node ;
-: #push ( -- node ) \ #push empty-node ;
+: #push ( -- node ) \ #push new ;
-TUPLE: #shuffle ;
+TUPLE: #shuffle < node ;
-: #shuffle ( -- node ) \ #shuffle empty-node ;
+: #shuffle ( -- node ) \ #shuffle new ;
-TUPLE: #>r ;
+TUPLE: #>r < node ;
-: #>r ( -- node ) \ #>r empty-node ;
+: #>r ( -- node ) \ #>r new ;
-TUPLE: #r> ;
+TUPLE: #r> < node ;
-: #r> ( -- node ) \ #r> empty-node ;
+: #r> ( -- node ) \ #r> new ;
-TUPLE: #values ;
+TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ;
-TUPLE: #return ;
+TUPLE: #return < node ;
: #return ( label -- node )
- \ #return all-in-node [ set-node-param ] keep ;
+ \ #return all-in-node swap >>param ;
+
+TUPLE: #branch < node ;
-TUPLE: #if ;
+TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ;
-TUPLE: #dispatch ;
+TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
-TUPLE: #merge ;
+TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ;
-TUPLE: #terminate ;
+TUPLE: #terminate < node ;
-: #terminate ( -- node ) \ #terminate empty-node ;
+: #terminate ( -- node ) \ #terminate new ;
-TUPLE: #declare ;
+TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ;
-UNION: #branch #if #dispatch ;
-
: node-inputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-in-r
- >r d-tail flatten-curries r> set-node-in-d ;
+ [ swap d-tail flatten-curries >>in-d drop ]
+ [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-out-r
- >r d-tail flatten-curries r> set-node-out-d ;
+ [ swap d-tail flatten-curries >>out-d drop ]
+ [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- )
dataflow-graph get [
] if ;
: node-values ( node -- values )
- dup node-in-d
- over node-out-d
- pick node-in-r
- roll node-out-r 4array concat ;
+ { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
+ 4array concat ;
: last-node ( node -- last )
- dup node-successor [ last-node ] [ ] ?if ;
+ dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
- dup node-successor dup [
- dup node-successor
+ dup successor>> dup [
+ dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor suffix r>
+ >r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains?
] if
] [
M: node calls-label* 2drop f ;
-M: #call-label calls-label* node-param eq? ;
+M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
- dup node-param swap calls-label? ;
+ [ param>> ] keep calls-label? ;
SYMBOL: node-stack
: node> node-stack get pop ;
: node@ node-stack get peek ;
-: iterate-next ( -- node ) node@ node-successor ;
+: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
] iterate-nodes drop
] with-node-iterator ; inline
-: change-children ( node quot -- )
+: map-children ( node quot -- )
over [
- >r dup node-children dup r>
- [ map swap set-node-children ] curry
- [ 2drop ] if
+ over children>> [
+ [ map ] curry change-children drop
+ ] [
+ 2drop
+ ] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
- dup rot set-node-successor
- dup node-successor r> (transform-nodes)
+ >>successor
+ successor>> dup successor>>
+ r> (transform-nodes)
] [
- r> drop f swap set-node-successor drop
+ r> 2drop f >>successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
- [ call dup dup node-successor ] keep (transform-nodes)
+ [ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
- dup value? >r swap node-literals key? r> or ;
+ dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj )
dup value?
- [ nip value-literal ] [ swap node-literals at ] if ;
+ [ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval )
- swap node-intervals at ;
+ swap intervals>> at ;
: node-class ( node value -- class )
- swap node-classes at object or ;
+ swap classes>> at object or ;
: node-input-classes ( node -- seq )
- dup node-in-d [ node-class ] with map ;
+ dup in-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
- dup node-in-d [ node-interval ] with map ;
+ dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class )
- dup node-in-d first node-class ;
+ dup in-d>> first node-class ;
: active-children ( node -- seq )
- node-children
- [ last-node ] map
- [ #terminate? not ] subset ;
+ children>> [ last-node ] map [ #terminate? not ] subset ;
DEFER: #tail?
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
- node-successor dup #tail? swap #terminate? not and
+ successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.errors
USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
-assocs ;
+assocs accessors ;
M: inference-error error.
- dup inference-error-rstate
+ dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
- swap delegate error. "Nesting: " write . ;
+ swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ;
+ARTICLE: "inference-errors" "Inference errors"
+"Main wrapper for all inference errors:"
+{ $subsection inference-error }
+"Specific inference errors:"
+{ $subsection no-effect }
+{ $subsection literal-expected }
+{ $subsection too-many->r }
+{ $subsection too-many-r> }
+{ $subsection unbalanced-branches-error }
+{ $subsection effect-error }
+{ $subsection recursive-declare-error } ;
+
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
$nl
{ $subsection "inference-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-recursive" }
-{ $subsection "inference-limitations" }
+{ $subsection "inference-limitations" }
+{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
- { $list
- { $link no-effect }
- { $link literal-expected }
- { $link too-many->r }
- { $link too-many-r> }
- { $link unbalanced-branches-error }
- { $link effect-error }
- { $link recursive-declare-error }
- }
+ "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
io.timeouts io.thread sequences.private ;
IN: inference.tests
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
\ declare [
1 ensure-values
M: composed infer-call
infer-uncurry
- infer->r peek-d infer-call
- terminated? get [ infer-r> peek-d infer-call ] unless ;
+ 1 infer->r peek-d infer-call
+ terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ literal-expected inference-warning ;
\ (directory) { string } { array } <effect> set-primitive-effect
-\ data-gc { } { } <effect> set-primitive-effect
-
-\ code-gc { } { } <effect> set-primitive-effect
+\ gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
-\ code-room { } { integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> set-primitive-effect
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ set-os-env { string string } { } <effect> set-primitive-effect
+
+\ unset-os-env { string } { } <effect> set-primitive-effect
+
\ (set-os-envs) { array } { } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect
+
+\ unimplemented { } { } <effect> set-primitive-effect
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ construct-empty must-infer
+\ new must-infer
TUPLE: a-tuple x y z ;
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic ;
+inspector hashtables classes generic sets ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
] 1 define-transform
-\ construct-boa [
+\ boa [
dup +inlined+ depends-on
tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
-\ construct-empty [
+\ new [
1 ensure-values
peek-d value? [
pop-literal
tuple-layout [ <tuple> ] curry
swap infer-quot
] [
- \ construct-empty 1 1 <effect> make-call-node
+ \ new 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
-quotations mirrors splitting math.parser classes vocabs refs ;
+quotations mirrors splitting math.parser classes vocabs refs
+sets ;
IN: inspector
GENERIC: summary ( object -- string )
<PRIVATE
-M: tuple-class <decoder> construct-empty <decoder> ;
-M: tuple <decoder> f decoder construct-boa ;
+M: tuple-class <decoder> new <decoder> ;
+M: tuple <decoder> f decoder boa ;
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
M: decoder dispose decoder-stream dispose ;
! Encoding
-M: tuple-class <encoder> construct-empty <encoder> ;
-M: tuple <encoder> encoder construct-boa ;
+M: tuple-class <encoder> new <encoder> ;
+M: tuple <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
- { [ t ] [ drop replacement-char ] }
+ [ drop replacement-char ]
} cond ;
: decode-utf8 ( stream -- char/f )
2dup -6 shift encoded
encoded
] }
- { [ t ] [
+ [
2dup -18 shift BIN: 11110000 bitor swap stream-write1
2dup -12 shift encoded
2dup -6 shift encoded
encoded
- ] }
+ ]
} cond ;
M: utf8 encode-char
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
+"Reading and writing the entire contents of a file; this is only recommended for smaller files:"
+{ $subsection file-contents }
+{ $subsection set-file-contents }
+{ $subsection file-lines }
+{ $subsection set-file-lines }
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
-{ $subsection with-file-appender }
-{ $subsection file-contents }
-{ $subsection file-lines } ;
+{ $subsection with-file-appender } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
{ $subsection pathname }
{ $subsection <pathname> } ;
-ARTICLE: "directories" "Directories"
-"Current directory:"
-{ $subsection with-directory }
+ARTICLE: "symbolic-links" "Symbolic links"
+"Reading and creating links:"
+{ $subsection read-link }
+{ $subsection make-link }
+"Copying links:"
+{ $subsection copy-link }
+"Not all operating systems support symbolic links."
+{ $see-also link-info } ;
+
+ARTICLE: "current-directory" "Current working directory"
+"File system I/O operations use the value of a variable to resolve relative pathnames:"
{ $subsection current-directory }
+"This variable can be changed with a pair of words:"
+{ $subsection set-current-directory }
+{ $subsection with-directory }
+"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
+{ $subsection (normalize-path) }
+"The second is to change the working directory of the current process:"
+{ $subsection cd }
+{ $subsection cwd } ;
+
+ARTICLE: "directories" "Directories"
"Home directory:"
{ $subsection home }
-"Current system directory:"
-{ $subsection cwd }
-{ $subsection cd }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
"Creating directories:"
{ $subsection make-directory }
-{ $subsection make-directories } ;
-
-! ARTICLE: "file-types" "File Types"
-
-! { $table { +directory+ "" } }
-
-! ;
-
-ARTICLE: "fs-meta" "File meta-data"
-
+{ $subsection make-directories }
+{ $subsection "current-directory" } ;
+
+ARTICLE: "file-types" "File Types"
+"Platform-independent types:"
+{ $subsection +regular-file+ }
+{ $subsection +directory+ }
+"Platform-specific types:"
+{ $subsection +character-device+ }
+{ $subsection +block-device+ }
+{ $subsection +fifo+ }
+{ $subsection +symbolic-link+ }
+{ $subsection +socket+ }
+{ $subsection +unknown+ } ;
+
+ARTICLE: "fs-meta" "File metadata"
+"Querying file-system metadata:"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
-{ $subsection directory? } ;
+{ $subsection directory? }
+"File types:"
+{ $subsection "file-types" } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"Operations for deleting and copying files come in two forms:"
{ $subsection "file-streams" }
{ $subsection "fs-meta" }
{ $subsection "directories" }
-{ $subsection "delete-move-copy" }
-{ $see-also "os" } ;
+{ $subsection "delete-move-copy" } ;
ABOUT: "io.files"
! need a $class-description file-info
HELP: file-info
+{ $values { "path" "a pathname string" } { "info" file-info } }
+{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
+{ $errors "Throws an error if the file does not exist." } ;
- { $values { "path" "a pathname string" }
- { "info" file-info } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, it is followed."
- "If the file does not exist, an exception is thrown." }
+HELP: link-info
+{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
+{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
- { $class-description "File meta data" }
+{ file-info link-info } related-words
- { $table
- { "type" { "One of the following:"
- { $list { $link +regular-file+ }
- { $link +directory+ }
- { $link +symbolic-link+ } } } }
+HELP: +regular-file+
+{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ;
- { "size" "Size of the file in bytes" }
- { "modified" "Last modification timestamp." } }
+HELP: +directory+
+{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ;
- ;
+HELP: +symbolic-link+
+{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ;
-! need a see also to link-info
+HELP: +character-device+
+{ $description "A Unix character device file. This type exists on unix platforms only." } ;
-HELP: link-info
- { $values { "path" "a pathname string" }
- { "info" "a file-info tuple" } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, information about "
- "the symbolic link itself is returned."
- "If the file does not exist, an exception is thrown." } ;
-! need a see also to file-info
+HELP: +block-device+
+{ $description "A Unix block device file. This type exists on unix platforms only." } ;
-{ file-info link-info } related-words
+HELP: +fifo+
+{ $description "A Unix fifo file. This type exists on unix platforms only." } ;
+
+HELP: +socket+
+{ $description "A Unix socket file. This type exists on unix platforms only." } ;
+
+HELP: +unknown+
+{ $description "A unknown file type." } ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
+HELP: set-file-lines
+{ $values { "seq" "an array of strings" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to the strings with the given encoding." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
HELP: file-lines
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+HELP: set-file-contents
+{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to a string with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
-{ $errors "Throws an error if the file cannot be opened for writing." } ;
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+{ set-file-lines file-lines set-file-contents file-contents } related-words
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
+
+{ cd cwd current-directory set-current-directory with-directory } related-words
-{ cd cwd current-directory with-directory } related-words
+HELP: current-directory
+{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
+$nl
+"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
+
+HELP: set-current-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Changes the " { $link current-directory } " variable."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
+{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
+HELP: prepend-path
+{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
+{ $description "Concatenates two pathnames." } ;
+
+{ append-path prepend-path } related-words
+
+HELP: absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
+
+HELP: windows-absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
+
+HELP: root-directory?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
+
+{ absolute-path? windows-absolute-path? root-directory? } related-words
+
HELP: exists?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
-{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
+{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;
{ $values { "str" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ;
+HELP: make-link
+{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
+{ $description "Creates a symbolic link." } ;
+
+HELP: read-link
+{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
+{ $description "Reads the symbolic link and returns its target path." } ;
+
+HELP: copy-link
+{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
+{ $description "Copies a symbolic link without following the link." } ;
+
+{ make-link read-link copy-link } related-words
+
HELP: home
{ $values { "dir" string } }
{ $description "Outputs the user's home directory." } ;
IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations
-io.encodings.ascii io.files.unique sequences strings accessors
-io.encodings.utf8 ;
+USING: tools.test io.files io.files.private io threads kernel
+continuations io.encodings.ascii io.files.unique sequences
+strings accessors io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
1 tail left-trim-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
- { [ t ] [ nip ] }
+ [ nip ]
} cond ;
PRIVATE>
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
- { [ t ] [ f ] }
+ [ f ]
} cond ;
: absolute-path? ( path -- ? )
{ [ dup "resource:" head? ] [ t ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
: append-path ( str1 str2 -- str )
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
- { [ t ] [
+ [
>r right-trim-separators "/" r>
left-trim-separators 3append
- ] }
+ ]
} cond ;
: prepend-path ( str1 str2 -- str )
! Symlinks
HOOK: link-info io-backend ( path -- info )
-HOOK: make-link io-backend ( path1 path2 -- )
+HOOK: make-link io-backend ( target symlink -- )
-HOOK: read-link io-backend ( path -- info )
+HOOK: read-link io-backend ( symlink -- path )
-: copy-link ( path1 path2 -- )
+: copy-link ( target symlink -- )
>r read-link r> make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
+SYMBOL: +symbolic-link+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
-SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
M: object normalize-path ( path -- path' )
(normalize-path) ;
-: with-directory ( path quot -- )
- >r (normalize-path) r>
- current-directory swap with-variable ; inline
-
: set-current-directory ( path -- )
- normalize-path current-directory set ;
+ (normalize-path) current-directory set ;
+
+: with-directory ( path quot -- )
+ >r (normalize-path) current-directory r> with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
{ [ dup exists? ] [ ] }
- { [ t ] [
+ [
dup parent-directory make-directories
dup make-directory
- ] }
+ ]
} cond drop ;
! Directory listings
M: pathname <=> [ pathname-string ] compare ;
! Home directory
-: home ( -- dir )
- {
- { [ os winnt? ] [ "USERPROFILE" os-env ] }
- { [ os wince? ] [ "" resource-path ] }
- { [ os unix? ] [ "HOME" os-env ] }
- } cond ;
+HOOK: home os ( -- dir )
+
+M: winnt home "USERPROFILE" os-env ;
+
+M: wince home "" resource-path ;
+
+M: unix home "HOME" os-env ;
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
-{ $subsection <duplex-stream> }
-{ $subsection check-closed } ;
+{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
HELP: duplex-stream
-{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ;
+{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
-HELP: check-closed
-{ $values { "stream" "a duplex stream" } }
-{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
+HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
-: <closing-stream> closing-stream construct-empty ;
+: <closing-stream> closing-stream new ;
M: closing-stream dispose
dup closing-stream-closed? [
TUPLE: unclosable-stream ;
-: <unclosable-stream> unclosable-stream construct-empty ;
+: <unclosable-stream> unclosable-stream new ;
M: unclosable-stream dispose
"Can't close me!" throw ;
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations io accessors ;
IN: io.streams.duplex
-USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
-TUPLE: duplex-stream in out closed? ;
+TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
- f duplex-stream construct-boa ;
+ f duplex-stream boa ;
ERROR: stream-closed-twice ;
-: check-closed ( stream -- )
- duplex-stream-closed? [ stream-closed-twice ] when ;
+<PRIVATE
-: duplex-stream-in+ ( duplex -- stream )
- dup check-closed duplex-stream-in ;
+: check-closed ( stream -- stream )
+ dup closed>> [ stream-closed-twice ] when ; inline
-: duplex-stream-out+ ( duplex -- stream )
- dup check-closed duplex-stream-out ;
+: in ( duplex -- stream ) check-closed in>> ;
+
+: out ( duplex -- stream ) check-closed out>> ;
+
+PRIVATE>
M: duplex-stream stream-flush
- duplex-stream-out+ stream-flush ;
+ out stream-flush ;
M: duplex-stream stream-readln
- duplex-stream-in+ stream-readln ;
+ in stream-readln ;
M: duplex-stream stream-read1
- duplex-stream-in+ stream-read1 ;
+ in stream-read1 ;
M: duplex-stream stream-read-until
- duplex-stream-in+ stream-read-until ;
+ in stream-read-until ;
M: duplex-stream stream-read-partial
- duplex-stream-in+ stream-read-partial ;
+ in stream-read-partial ;
M: duplex-stream stream-read
- duplex-stream-in+ stream-read ;
+ in stream-read ;
M: duplex-stream stream-write1
- duplex-stream-out+ stream-write1 ;
+ out stream-write1 ;
M: duplex-stream stream-write
- duplex-stream-out+ stream-write ;
+ out stream-write ;
M: duplex-stream stream-nl
- duplex-stream-out+ stream-nl ;
+ out stream-nl ;
M: duplex-stream stream-format
- duplex-stream-out+ stream-format ;
+ out stream-format ;
M: duplex-stream make-span-stream
- duplex-stream-out+ make-span-stream ;
+ out make-span-stream ;
M: duplex-stream make-block-stream
- duplex-stream-out+ make-block-stream ;
+ out make-block-stream ;
M: duplex-stream make-cell-stream
- duplex-stream-out+ make-cell-stream ;
+ out make-cell-stream ;
M: duplex-stream stream-write-table
- duplex-stream-out+ stream-write-table ;
+ out stream-write-table ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
- dup duplex-stream-closed? [
- t over set-duplex-stream-closed?
- [ dup duplex-stream-out dispose ]
- [ dup duplex-stream-in dispose ] [ ] cleanup
+ dup closed>> [
+ t >>closed
+ [ dup out>> dispose ]
+ [ dup in>> dispose ] [ ] cleanup
] unless drop ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
-quotations io continuations ;
+quotations io continuations accessors sequences ;
+IN: io.streams.nested
+
+TUPLE: filter-writer stream ;
+
+M: filter-writer stream-format
+ stream>> stream-format ;
+
+M: filter-writer stream-write
+ stream>> stream-write ;
+
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
+
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
+
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
-TUPLE: ignore-close-stream ;
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
-: <ignore-close-stream> ignore-close-stream construct-delegate ;
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ stream>> dispose ;
+
+TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
-TUPLE: style-stream style ;
+C: <ignore-close-stream> ignore-close-stream
-: do-nested-style ( style stream -- style delegate )
- [ style-stream-style swap union ] keep
- delegate ; inline
+TUPLE: style-stream < filter-writer style ;
-: <style-stream> ( style delegate -- stream )
- { set-style-stream-style set-delegate }
- style-stream construct ;
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap assoc-union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
- dup style-stream-style swap delegate stream-format ;
+ [ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
>r 1string r> stream-write ;
do-nested-style make-span-stream ;
M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] keep
- style-stream-style swap <style-stream> ;
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] keep
- style-stream-style swap <style-stream> ;
-
-TUPLE: block-stream ;
-
-: <block-stream> block-stream construct-delegate ;
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
-M: block-stream dispose drop ;
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
nip stream-write ;
M: plain-writer make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
-{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
+{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "."
-$nl
-"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
+{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
+{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"
HELP: clear
{ $description "Clears the data stack." } ;
+HELP: build
+{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ;
+
HELP: hashcode*
{ $values { "depth" integer } { "obj" object } { "code" fixnum } }
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
- "Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings."
+ "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } }
+HELP: compose ( quot1 quot2 -- compose )
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
{ $code
"compose call"
"append call"
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] must-fail
+
+! Discovered on Windows
+: total-failure-1 "" [ ] map unimplemented ;
+
+[ total-failure-1 ] must-fail
+
+: total-failure-2 [ ] (call) unimplemented ;
+
+[ total-failure-2 ] must-fail
M: object hashcode* 2drop 0 ;
+M: f hashcode* 2drop 31337 ;
+
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
M: callstack clone (clone) ;
! Tuple construction
-: construct-empty ( class -- tuple )
+: new ( class -- tuple )
tuple-layout <tuple> ;
-: construct-boa ( ... class -- tuple )
+: boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Quotation building
PRIVATE>
! Deprecated
-GENERIC: delegate ( obj -- delegate )
-
M: object delegate drop f ;
-GENERIC: set-delegate ( delegate tuple -- )
-
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ; inline
+ new [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline
USING: generic help.markup help.syntax kernel math
memory namespaces sequences kernel.private classes
-sequences.private ;
+classes.builtin sequences.private ;
IN: layouts
HELP: tag-bits
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units ;
+continuations debugger definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
- dup delegate unexpected-eof?
+ dup error>> unexpected-eof?
[ 2drop f ] [ rethrow ] if
] recover ;
2drop over second over second and
[ <interval> ] [ 2drop f ] if
] }
- { [ t ] [ 2drop <interval> ] }
+ [ 2drop <interval> ]
} cond ;
: interval-intersect ( i1 i2 -- i3 )
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: interval> ( i1 i2 -- ? )
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+HELP: before?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: before=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+{ before? after? before=? after=? } related-words
+
+
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ $description
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
+: ?1+ [ 1+ ] [ 0 ] if* ; inline
+
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
- { [ t ] [ radix get [ < ] curry all? ] }
+ [ radix get [ < ] curry all? ]
} cond ;
: string>integer ( str -- n/f )
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
- { [ t ] [ string>integer ] }
+ [ string>integer ]
} cond
r> [ dup [ neg ] when ] when
] with-radix ;
} {
[ CHAR: . over member? ]
[ ]
- } {
- [ t ]
- [ ".0" append ]
}
+ [ ".0" append ]
} cond ;
M: float >base
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ t ] [ float>string fix-float ] }
+ [ float>string fix-float ]
} cond ;
: number>string ( n -- str ) 10 >base ;
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
-HELP: data-gc ( -- )
+HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: code-gc ( -- )
-{ $description "Collects all generations up to and including tenured space, and also collects the code heap." } ;
-
HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
USING: generic kernel kernel.private math memory prettyprint
-sequences tools.test words namespaces layouts classes ;
+sequences tools.test words namespaces layouts classes
+classes.builtin arrays quotations ;
IN: memory.tests
+! Code GC wasn't kicking in when needed
+: leak-step 800000 f <array> 1quotation call drop ;
+
+: leak-loop 100 [ leak-step ] times ;
+
+[ ] [ leak-loop ] unit-test
+
TUPLE: testing x y z ;
[ save-image-and-exit ] must-fail
TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
- dup object-slots mirror construct-boa ;
+ dup object-slots mirror boa ;
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
- [ slot-spec-name ] map swap 2array flip ;
+ [ slot-spec-name ] map swap zip ;
M: mirror assoc-size mirror-slots length ;
GENERIC: optimize-node* ( node -- node/t changed? )
: ?union ( assoc/f assoc -- hash )
- over [ union ] [ nip ] if ;
+ over [ assoc-union ] [ nip ] if ;
: add-node-literals ( assoc node -- )
over assoc-empty? [
DEFER: optimize-nodes
: optimize-children ( node -- )
- [ optimize-nodes ] change-children ;
+ [ optimize-nodes ] map-children ;
: optimize-node ( node -- node )
dup [
2dup at* [ swap follow nip ] [ 2drop ] if ;
: union* ( assoc1 assoc2 -- assoc )
- union [ keys ] keep
+ assoc-union [ keys ] keep
[ dupd follow ] curry
H{ } map>assoc ;
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? not ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
+ [ 2drop t ]
} cond
] curry node-exists? ;
: label-is-not-loop? ( node word -- ? )
[
{
- { [ over #label? not ] [ 2drop f ] }
- { [ over #label-word over eq? not ] [ 2drop f ] }
- { [ over #label-loop? ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
- } cond
+ { [ over #label? not ] [ f ] }
+ { [ over #label-word over eq? not ] [ f ] }
+ { [ over #label-loop? ] [ f ] }
+ [ t ]
+ } cond 2nip
] curry node-exists? ;
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
-
+
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
{ [ dup null class< ] [ drop f f ] }
{ [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
- { [ t ] [ drop f f ] }
+ [ drop f f ]
} cond
] if ;
dup [
dup [ dead-literals get swap remove-all ] modify-values
dup kill-node* dup t eq? [
- drop dup [ kill-nodes ] change-children
+ drop dup [ kill-nodes ] map-children
] [
nip kill-node
] if
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
- { [ t ] [ dup dup set word-def (flat-length) ] }
+ [ dup dup set word-def (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
- { [ t ] [ drop 1 ] }
+ [ drop 1 ]
} cond
] map sum ;
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ t ] [ 2drop t ] }
+ [ 2drop t ]
} cond ;
! Resolve type checks at compile time where possible
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
- { [ t ] [ inline-method ] }
+ [ inline-method ]
} cond dup not ;
] "output-classes" set-word-prop
] each
-\ construct-empty [
+\ new [
dup node-in-d peek node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
[ breakage ] must-fail
! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+[ ] [ [ new ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
HINTS: recursive-inline-hang-3 array ;
+! Regression
+USE: sequences.private
+[ ] [ { (3append) } compile ] unit-test
{ [ dup @ eq? ] [ drop match-@ ] }
{ [ dup class? ] [ match-class ] }
{ [ over value? not ] [ 2drop f ] }
- { [ t ] [ swap value-literal = ] }
+ [ swap value-literal = ]
} cond ;
: node-match? ( node values pattern -- ? )
[ dup "specializer" word-prop ]\r
[ "specializer" word-prop specialize-quot ]\r
}\r
- { [ t ] [ drop ] }\r
+ [ drop ]\r
} cond ;\r
\r
: specialized-length ( specializer -- n )\r
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units ;
+quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
{ $subsection parse-file }
{ $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
+$nl
+"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
{ $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can also parse from a stream:"
{ $subsection parse-stream } ;
+ARTICLE: "top-level-forms" "Top level forms"
+"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
+$nl
+"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
+$nl
+"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
+
ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
{ $subsection "parser-usage" }
+{ $subsection "top-level-forms" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
-HELP: shadow-warnings
-{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
-{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
-
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+ { $code
+ "TUPLE: my-mistaken-tuple slot-a slot-b"
+ ""
+ ": some-word ( a b c -- ) ... ;"
+ }
+} ;
+
HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
-HELP: outside-usages
-{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
-{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ;
-
HELP: filter-moved
-{ $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } }
-{ $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ;
-
-HELP: smudged-usage
-{ $values { "usages" "a sequence of definitions which reference removed definitions" } { "referenced" "a sequence of definitions removed from this source file which are still referenced elsewhere" } { "removed" "a sequence of definitions removed from this source file" } }
-{ $description "Collects information about changed word definitioins after parsing." } ;
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an seqence of definitions" } }
+{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader ;
+vocabs.loader accessors ;
IN: parser.tests
[
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
] must-fail
] with-file-vocabs
-[
- << file get parsed >> file set
-
- : ~a ;
-
- DEFER: ~b
-
- "IN: parser.tests : ~b ~a ;" <string-reader>
- "smudgy" parse-stream drop
-
- : ~c ;
- : ~d ;
-
- { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
-
- { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
-
- [ V{ ~b } { ~a } { ~a ~c } ] [
- smudged-usage
- natural-sort
- ] unit-test
-] with-scope
-
-[
- << file get parsed >> file set
-
- GENERIC: ~e
-
- : ~f ~e ;
-
- : ~g ;
-
- { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
-
- { H{ { ~g ~g } } H{ } } new-definitions set
-
- [ V{ } { } { ~e ~f } ]
- [ smudged-usage natural-sort ]
- unit-test
-] with-scope
-
[ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs kernel math
-namespaces prettyprint sequences strings vectors words
-quotations inspector io.styles io combinators sorting
-splitting math.parser effects continuations debugger
-io.files io.streams.string vocabs io.encodings.utf8
-source-files classes hashtables compiler.errors compiler.units
-accessors ;
+USING: arrays definitions generic assocs kernel math namespaces
+prettyprint sequences strings vectors words quotations inspector
+io.styles io combinators sorting splitting math.parser effects
+continuations debugger io.files io.streams.string vocabs
+io.encodings.utf8 source-files classes classes.tuple hashtables
+compiler.errors compiler.units accessors sets ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
0 >>column
drop ;
+: new-lexer ( text class -- lexer )
+ new
+ 0 >>line
+ swap >>text
+ dup next-line ; inline
+
: <lexer> ( text -- lexer )
- 0 { set-lexer-text set-lexer-line } lexer construct
- dup next-line ;
+ lexer new-lexer ;
: location ( -- loc )
file get lexer get lexer-line 2dup and
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-TUPLE: parse-error file line col text ;
+TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
- file get
- lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
- parse-error construct-boa
- [ set-delegate ] keep ;
+ \ parse-error new
+ file get >>file
+ lexer get line>> >>line
+ lexer get column>> >>column
+ lexer get line-text>> >>line-text
+ swap >>error ;
: parse-dump ( error -- )
- dup parse-error-file file.
- dup parse-error-line number>string print
- dup parse-error-text dup string? [ print ] [ drop ] if
- parse-error-col 0 or CHAR: \s <string> write
+ {
+ [ file>> file. ]
+ [ line>> number>string print ]
+ [ line-text>> dup string? [ print ] [ drop ] if ]
+ [ column>> 0 or CHAR: \s <string> write ]
+ } cleave
"^" print ;
M: parse-error error.
- dup parse-dump delegate error. ;
+ [ parse-dump ] [ error>> error. ] bi ;
+
+M: parse-error summary
+ error>> summary ;
+
+M: parse-error compute-restarts
+ error>> compute-restarts ;
+
+M: parse-error error-help
+ error>> error-help ;
SYMBOL: use
SYMBOL: in
: word/vocab% ( word -- )
"(" % dup word-vocabulary % " " % word-name % ")" % ;
-: shadow-warning ( new old -- )
- 2dup eq? [
- 2drop
- ] [
- [ word/vocab% " shadowed by " % word/vocab% ] "" make
- note.
- ] if ;
-
-: shadow-warnings ( vocab vocabs -- )
- [
- swapd assoc-stack dup
- [ shadow-warning ] [ 2drop ] if
- ] curry assoc-each ;
-
: (use+) ( vocab -- )
- vocab-words use get 2dup shadow-warnings push ;
+ vocab-words use get push ;
: use+ ( vocab -- )
load-vocab (use+) ;
drop "Word not found in current vocabulary search path" ;
: no-word ( name -- newword )
- dup no-word-error construct-boa
+ dup no-word-error boa
swap words-named [ forward-reference? not ] subset
word-restarts throw-restarts
dup word-vocabulary (use+) ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
+: shadowed-slots ( superclass slots -- shadowed )
+ >r all-slot-names r> intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+ shadowed-slots [
+ [
+ "Definition of slot ``" %
+ %
+ "'' in class ``" %
+ word-name %
+ "'' shadows a superclass slot" %
+ ] "" make note.
+ ] with each ;
+
+ERROR: invalid-slot-name name ;
+
+M: invalid-slot-name summary
+ drop
+ "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+ #! This isn't meant to enforce any kind of policy, just
+ #! to check for mistakes of this form:
+ #!
+ #! TUPLE: blahblah foo bing
+ #!
+ #! : ...
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop ] }
+ [ , (parse-tuple-slots) ]
+ } cond ;
+
+: parse-tuple-slots ( -- seq )
+ [ (parse-tuple-slots) ] { } make ;
+
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
- { "<" [ scan-word ";" parse-tokens ] }
- [ >r tuple ";" parse-tokens r> prefix ]
- } case ;
+ { "<" [ scan-word parse-tuple-slots ] }
+ [ >r tuple parse-tuple-slots r> prefix ]
+ } case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
- { [ t ] [ pick push drop t ] }
+ [ pick push drop t ]
} cond ;
: (parse-until) ( accum end -- accum )
SYMBOL: interactive-vocabs
{
+ "accessors"
"arrays"
"assocs"
"combinators"
"Loading " write <pathname> . flush
] if ;
-: smudged-usage-warning ( usages removed -- )
- parser-notes? [
- "Warning: the following definitions were removed from sources," print
- "but are still referenced from other definitions:" print
- nl
- dup sorted-definitions.
- nl
- "The following definitions need to be updated:" print
- nl
- over sorted-definitions.
- nl
- ] when 2drop ;
-
: filter-moved ( assoc1 assoc2 -- seq )
- diff [
+ assoc-diff [
drop where dup [ first ] when
file get source-file-path =
] assoc-subset keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
- [ get first2 union ] bi@ ;
+ [ get first2 assoc-union ] bi@ ;
: removed-classes ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get second ] bi@ ;
-: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved [
- outside-usages
- [
- empty? [ drop f ] [
- {
- { [ dup pathname? ] [ f ] }
- { [ dup method-body? ] [ f ] }
- { [ t ] [ t ] }
- } cond nip
- ] if
- ] assoc-subset
- dup values concat prune swap keys
- ] keep ;
+: forget-removed-definitions ( -- )
+ removed-definitions filter-moved forget-all ;
+
+: reset-removed-classes ( -- )
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
- filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
- removed-classes
- filter-moved [ class? ] subset [ reset-class ] each ;
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
: forget-smudged ( -- )
- smudged-usage forget-all
- over empty? [ 2dup smudged-usage-warning ] unless 2drop
+ forget-removed-definitions
+ reset-removed-classes
fix-class-words ;
: finish-parsing ( lines quot -- )
ABOUT: "prettyprint-variables"
-HELP: indent
-{ $var-description "The prettyprinter's current indent level." } ;
-
-HELP: pprinter-stack
-{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
-
HELP: tab-size
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size." } ;
"On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ;
ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol"
-"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol."
+"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol."
$nl
"Layout queries:"
{ $subsection section-fits? }
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection <section> }
-{ $subsection delegate>block }
+{ $subsection new-section }
+{ $subsection new-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
[ \ predicate-see-test see ] with-string-writer
] unit-test
+
+[ ] [ \ compose see ] unit-test
+[ ] [ \ curry see ] unit-test
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
-definitions effects classes.tuple io.files classes continuations
-hashtables classes.mixin classes.union classes.predicate
-classes.singleton combinators quotations ;
+definitions effects classes.builtin classes.tuple io.files
+classes continuations hashtables classes.mixin classes.union
+classes.predicate classes.singleton combinators quotations
+sets ;
: make-pprint ( obj quot -- block in use )
[
{ [ dup word? not ] [ , ] }
{ [ dup "break?" word-prop ] [ drop ] }
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
- { [ t ] [ , ] }
+ [ , ]
} cond
] each
] [ ] make ;
USING: prettyprint io kernel help.markup help.syntax
-prettyprint.sections prettyprint.config words hashtables math
+prettyprint.config words hashtables math
strings definitions ;
+IN: prettyprint.sections
HELP: position
{ $var-description "The prettyprinter's current character position." } ;
-HELP: last-newline
-{ $var-description "The character position of the last newline output by the prettyprinter." } ;
-
HELP: recursion-check
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
-HELP: line-count
-{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
-
-HELP: end-printing
-{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
-
HELP: line-limit?
{ $values { "?" "a boolean" } }
{ $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
{ $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be cutomized." } ;
HELP: section
-{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
+{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various subclasses of this class:"
{ $list
{ $link text }
{ $link line-break }
}
"Instances of this class have the following slots:"
{ $list
- { { $link section-start } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-end } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-start-group? } " - see " { $link start-group } }
- { { $link section-end } " - see " { $link end-group } }
- { { $link section-style } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
- { { $link section-overhang } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
+ { { $snippet "start" } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "end" } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "start-group?" } " - see " { $link start-group } }
+ { { $snippet "end-group?" } " - see " { $link end-group } }
+ { { $snippet "style" } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
+ { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
-HELP: <section>
-{ $values { "style" hashtable } { "length" integer } { "section" section } }
+HELP: new-section
+{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
-HELP: change-indent
-{ $values { "section" section } { "n" integer } }
-{ $description "If the section requests indentation, adds " { $snippet "n" } " to the indent level, otherwise does nothing." } ;
-
HELP: <indent
{ $values { "section" section } }
{ $description "Increases indentation by the " { $link tab-size } " if requested by the section." } ;
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested ;
+io.streams.nested accessors ;
IN: prettyprint.sections
! State
SYMBOL: recursion-check
SYMBOL: pprinter-stack
-SYMBOL: last-newline
-SYMBOL: line-count
-SYMBOL: end-printing
-SYMBOL: indent
-
! We record vocabs of all words
SYMBOL: pprinter-in
SYMBOL: pprinter-use
+TUPLE: pprinter last-newline line-count end-printing indent ;
+
+: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
+
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
! Utility words
: line-limit? ( -- ? )
- line-limit get dup [ line-count get <= ] when ;
+ line-limit get dup [ pprinter get line-count>> <= ] when ;
-: do-indent ( -- ) indent get CHAR: \s <string> write ;
+: do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
: fresh-line ( n -- )
- dup last-newline get = [
+ dup pprinter get last-newline>> = [
drop
] [
- last-newline set
- line-limit? [ "..." write end-printing get continue ] when
- line-count inc
+ pprinter get (>>last-newline)
+ line-limit? [
+ "..." write pprinter get end-printing>> continue
+ ] when
+ pprinter get [ 1+ ] change-line-count drop
nl do-indent
] if ;
: text-fits? ( len -- ? )
margin get dup zero?
- [ 2drop t ] [ >r indent get + r> <= ] if ;
+ [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
start-group? end-group?
style overhang ;
-: <section> ( style length -- section )
- position [ dup rot + dup ] change 0 {
- set-section-style
- set-section-start
- set-section-end
- set-section-overhang
- } section construct ;
+: new-section ( length class -- section )
+ new
+ position get >>start
+ swap position [ + ] change
+ position get >>end
+ 0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- dup section-end last-newline get -
- swap section-overhang + text-fits? ;
+ [ end>> pprinter get last-newline>> - ]
+ [ overhang>> ] bi
+ + text-fits? ;
M: section indent-section? drop f ;
M: object short-section? section-fits? ;
-: change-indent ( section n -- )
- swap indent-section? [ indent +@ ] [ drop ] if ;
+: indent+ ( section n -- )
+ swap indent-section? [
+ pprinter get [ + ] change-indent drop
+ ] [ drop ] if ;
-: <indent ( section -- ) tab-size get change-indent ;
+: <indent ( section -- ) tab-size get indent+ ;
-: indent> ( section -- ) tab-size get neg change-indent ;
+: indent> ( section -- ) tab-size get neg indent+ ;
: <fresh-line ( section -- )
- section-start fresh-line ;
+ start>> fresh-line ;
: fresh-line> ( section -- )
- dup newline-after? [ section-end fresh-line ] [ drop ] if ;
+ dup newline-after? [ end>> fresh-line ] [ drop ] if ;
: <long-section ( section -- )
dup unindent-first-line?
: long-section> ( section -- )
dup indent> fresh-line> ;
-: with-style* ( style quot -- )
- swap stdio [ <style-stream> ] change
- call stdio [ delegate ] change ; inline
-
: pprint-section ( section -- )
dup short-section? [
- dup section-style [ short-section ] with-style*
+ dup section-style [ short-section ] with-style
] [
- dup <long-section
- dup section-style [ dup long-section ] with-style*
- long-section>
+ [ <long-section ]
+ [ dup section-style [ long-section ] with-style ]
+ [ long-section> ]
+ tri
] if ;
! Break section
-TUPLE: line-break type ;
+TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- H{ } 0 <section>
- { set-line-break-type set-delegate }
- \ line-break construct ;
+ 0 \ line-break new-section
+ swap >>type ;
M: line-break short-section drop ;
M: line-break long-section drop ;
! Block sections
-TUPLE: block sections ;
+TUPLE: block < section sections ;
-: <block> ( style -- block )
- 0 <section> V{ } clone
- { set-delegate set-block-sections } block construct ;
+: new-block ( style class -- block )
+ 0 swap new-section
+ V{ } clone >>sections
+ swap >>style ; inline
-: delegate>block ( obj -- ) H{ } <block> swap set-delegate ;
+: <block> ( style -- block )
+ block new-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
: add-section ( section -- )
- pprinter-block block-sections push ;
+ pprinter-block sections>> push ;
: last-section ( -- section )
- pprinter-block block-sections
+ pprinter-block sections>>
[ line-break? not ] find-last nip ;
: start-group ( -- )
- t last-section set-section-start-group? ;
+ last-section t >>start-group? drop ;
: end-group ( -- )
- t last-section set-section-end-group? ;
+ last-section t >>end-group? drop ;
: advance ( section -- )
- dup section-start last-newline get = not
- swap short-section? and
- [ bl ] when ;
+ [ start>> pprinter get last-newline>> = not ]
+ [ short-section? ] bi
+ and [ bl ] when ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
- line-limit? [ drop t ] [ delegate section-fits? ] if ;
+ line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ line-break? not ] subset
+ swap sections>> [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup line-break-type hard eq?
- over section-end last-newline get - margin get 2/ > or
- [ <fresh-line ] [ drop ] if ;
+ [ ]
+ [ type>> hard eq? ]
+ [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
+ or [ <fresh-line ] [ drop ] if ;
-: empty-block? ( block -- ? ) block-sections empty? ;
+: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
-: <block H{ } <block> (<block) ;
+: <block f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
! Text section
-TUPLE: text string ;
+TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ <section>
- { set-text-string set-delegate }
- \ text construct ;
+ over length 1+ \ text new-section
+ swap >>style
+ swap >>string ;
M: text short-section text-string write ;
: text ( string -- ) H{ } styled-text ;
! Inset section
-TUPLE: inset narrow? ;
+TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- 2 H{ } <block>
- { set-inset-narrow? set-section-overhang set-delegate }
- inset construct ;
+ H{ } inset new-block
+ 2 >>overhang
+ swap >>narrow? ;
M: inset long-section
- dup inset-narrow? [
+ dup narrow?>> [
[ <fresh-line ] pprint-sections
] [
- delegate long-section
+ call-next-method
] if ;
M: inset indent-section? drop t ;
: <inset ( narrow? -- ) <inset> (<block) ;
! Flow section
-TUPLE: flow ;
+TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } <block> flow construct-delegate ;
+ H{ } flow new-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
- dup section-fits?
- over section-end rot section-start - text-fits? not or ;
+ [ section-fits? ]
+ [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
+ or ;
: <flow ( -- ) <flow> (<block) ;
! Colon definition section
-TUPLE: colon ;
+TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } <block> colon construct-delegate ;
+ H{ } colon new-block ;
M: colon long-section short-section ;
: <colon ( -- ) <colon> (<block) ;
: save-end-position ( block -- )
- position get swap set-section-end ;
+ position get >>end drop ;
: block> ( -- )
pprinter-stack get pop
- [ dup save-end-position add-section ] if-nonempty ;
-
-: with-section-state ( quot -- )
- [
- 0 indent set
- 0 last-newline set
- 1 line-count set
- call
- ] with-scope ; inline
+ [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
: do-pprint ( block -- )
- [
+ <pprinter> pprinter [
[
- dup section-style [
- [ end-printing set dup short-section ] callcc0
- ] with-nesting drop
+ dup style>> [
+ [
+ >r pprinter get (>>end-printing) r>
+ short-section
+ ] curry callcc0
+ ] with-nesting
] if-nonempty
- ] with-section-state ;
+ ] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
M: f section-end-group? drop f ;
: split-before ( section -- )
- dup section-start-group? prev get section-end-group? and
- swap flow? prev get flow? not and
- or split-groups ;
+ [ section-start-group? prev get section-end-group? and ]
+ [ flow? prev get flow? not and ]
+ bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
- dup first section-fits? swap peek section-fits? not and ;
+ [ first section-fits? ] [ peek section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
M: block long-section ( block -- )
[
- block-sections chop-break group-flow [
+ sections>> chop-break group-flow [
dup ?break-group [
dup line-break? [
do-break
] [
- dup advance pprint-section
+ [ advance ] [ pprint-section ] bi
] if
] each
] each
--- /dev/null
+USING: refs tools.test kernel ;
+
+[ 3 ] [
+ H{ { "a" 3 } } "a" <value-ref> get-ref
+] unit-test
+
+[ 4 ] [
+ 4 H{ { "a" 3 } } clone "a" <value-ref>
+ [ set-ref ] keep
+ get-ref
+] unit-test
+
+[ "a" ] [
+ H{ { "a" 3 } } "a" <key-ref> get-ref
+] unit-test
+
+[ H{ { "b" 3 } } ] [
+ "b" H{ { "a" 3 } } clone [
+ "a" <key-ref>
+ set-ref
+ ] keep
+] unit-test
TUPLE: ref assoc key ;
-: <ref> ( assoc key class -- tuple )
- >r ref construct-boa r> construct-delegate ; inline
-
-: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
+: >ref< [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
-TUPLE: key-ref ;
-: <key-ref> ( assoc key -- ref ) key-ref <ref> ;
-M: key-ref get-ref ref-key ;
+TUPLE: key-ref < ref ;
+C: <key-ref> key-ref ( assoc key -- ref )
+M: key-ref get-ref key>> ;
M: key-ref set-ref >ref< rename-at ;
-TUPLE: value-ref ;
-: <value-ref> ( assoc key -- ref ) value-ref <ref> ;
+TUPLE: value-ref < ref ;
+C: <value-ref> value-ref ( assoc key -- ref )
M: value-ref get-ref >ref< at ;
M: value-ref set-ref >ref< set-at ;
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
-[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
+[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
<PRIVATE
: string>sbuf ( string length -- sbuf )
- sbuf construct-boa ; inline
+ sbuf boa ; inline
PRIVATE>
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
-M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
+M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
-{ $subsection new }
+{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection seq-diff } ;
+{ $subsection remove } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection "sequences-split" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
+{ $subsection "sequences-sorting" }
+{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $description "Throws an " { $link immutable } " error." }
{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-HELP: new
+HELP: new-sequence
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
HELP: all?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
-{ $notes
- "The implementation makes use of a well-known logical identity:"
- $nl
- { $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
-} ;
+{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
-HELP: seq-diff
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
-
HELP: sum-lengths
{ $values { "seq" "a sequence of sequences" } { "n" integer } }
{ $description "Outputs the sum of the lengths of all sequences in " { $snippet "seq" } "." } ;
USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays
-generic ;
+generic vocabs.loader ;
IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
+[ "blah" ] [ "blahxx" 2 head* ] unit-test
+
+[ "xx" ] [ "blahxx" 2 tail* ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
+
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
+
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
-[ V{ f f f } ] [ 3 V{ } new ] unit-test
-[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
+[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
+[ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+! Hardcore
+[ ] [ "sequences" reload ] unit-test
GENERIC: set-length ( n seq -- )
GENERIC: nth ( n seq -- elt ) flushable
GENERIC: set-nth ( elt n seq -- )
-GENERIC: new ( len seq -- newseq ) flushable
+GENERIC: new-sequence ( len seq -- newseq ) flushable
GENERIC: new-resizable ( len seq -- newseq ) flushable
GENERIC: like ( seq exemplar -- newseq ) flushable
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
- over >r >r new r> call r> like ; inline
+ over >r >r new-sequence r> call r> like ; inline
M: sequence like drop ;
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new virtual-seq new ;
+M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
C: <reversed> reversed
M: reversed virtual-seq reversed-seq ;
+
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+
M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
- slice construct-boa ; inline
+ slice boa ; inline
M: slice virtual-seq slice-seq ;
+
M: slice virtual@ [ slice-from + ] keep slice-seq ;
+
M: slice length dup slice-to swap slice-from - ;
: head-slice ( seq n -- slice ) (head) <slice> ;
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
: prepare-subseq ( from to seq -- dst i src j n )
- [ >r swap - r> new dup 0 ] 3keep
+ [ >r swap - r> new-sequence dup 0 ] 3keep
-rot drop roll length ; inline
: check-copy ( src n dst -- )
(copy) drop ; inline
M: sequence clone-like
- >r dup length r> new [ 0 swap copy ] keep ;
+ >r dup length r> new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
-: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
- swap [ member? ] curry subset ;
-
: remove ( obj seq -- newseq )
[ = not ] with subset ;
2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+ swap [
+ dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+ fixnum+fast fixnum+fast
+ ] keep fixnum-bitxor ; inline
+
+: sequence-hashcode ( n seq -- x )
+ 0 -rot [
+ hashcode* >fixnum sequence-hashcode-step
+ ] with each ; inline
+
+M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+
+M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
: move ( to from seq -- )
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
[ 0 swap copy ] keep
] new-like ;
-: seq-diff ( seq1 seq2 -- newseq )
- swap [ member? not ] curry subset ;
-
: peek ( seq -- elt ) dup length 1- swap nth ;
: pop* ( seq -- ) dup length 1- swap set-length ;
dup [ length ] map infimum
[ <column> dup like ] with map
] unless ;
-
-: sequence-hashcode-step ( oldhash newpart -- newhash )
- swap [
- dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
- fixnum+fast fixnum+fast
- ] keep fixnum-bitxor ; inline
-
-: sequence-hashcode ( n seq -- x )
- 0 -rot [
- hashcode* >fixnum sequence-hashcode-step
- ] with each ; inline
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: kernel help.markup help.syntax sequences ;
+IN: sets
+
+ARTICLE: "sets" "Set-theoretic operations on sequences"
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+$nl
+"Remove duplicates:"
+{ $subsection prune }
+"Test for duplicates:"
+{ $subsection all-unique? }
+"Set operations on sequences:"
+{ $subsection diff }
+{ $subsection intersect }
+{ $subsection union }
+{ $see-also member? memq? contains? all? "assocs-sets" } ;
+
+HELP: unique
+{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $description "Outputs a new assoc where the keys and values are equal." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
+} ;
+
+HELP: prune
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
+} ;
+
+HELP: all-unique?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests whether a sequence contains any repeated elements." }
+{ $example
+ "USING: sets prettyprint ;"
+ "{ 0 1 1 2 3 5 } all-unique? ."
+ "f"
+} ;
+
+HELP: diff
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
+} { $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
+} ;
+
+HELP: intersect
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
+} ;
+
+HELP: union
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
+} ;
+
+{ diff intersect union } related-words
--- /dev/null
+USING: kernel sets tools.test ;
+IN: sets.tests
+
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
+
+[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
+[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
+
+[ { } ] [ { } { } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+
+[ { } ] [ { } { } diff ] unit-test
+[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+
+[ V{ } ] [ { } { } union ] unit-test
+[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel sequences vectors ;
+IN: sets
+
+: (prune) ( elt hash vec -- )
+ 3dup drop key?
+ [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
+ 3drop ; inline
+
+: prune ( seq -- newseq )
+ [ ] [ length <hashtable> ] [ length <vector> ] tri
+ [ [ (prune) ] 2curry each ] keep ;
+
+: unique ( seq -- assoc )
+ [ dup ] H{ } map>assoc ;
+
+: (all-unique?) ( elt hash -- ? )
+ 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+
+: all-unique? ( seq -- ? )
+ dup length <hashtable> [ (all-unique?) ] curry all? ;
+
+: intersect ( seq1 seq2 -- newseq )
+ unique [ key? ] curry subset ;
+
+: diff ( seq1 seq2 -- newseq )
+ swap unique [ key? not ] curry subset ;
+
+: union ( seq1 seq2 -- newseq )
+ append prune ;
--- /dev/null
+Set-theoretic operations on sequences
--- /dev/null
+collections
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
-effects generic.standard classes.tuple slots.private classes
-strings math ;
+effects generic.standard classes.tuple classes.builtin
+slots.private classes strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 ;
+graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
M: pathname where pathname-string 1 2array ;
: forget-source ( path -- )
- dup source-file
- dup unxref-source
- source-file-definitions [ keys forget-all ] each
- source-files get delete-at ;
+ [
+ source-file
+ [ unxref-source ]
+ [ definitions>> [ keys forget-all ] each ]
+ bi
+ ]
+ [ source-files get delete-at ]
+ bi ;
M: pathname forget*
pathname-string forget-source ;
: rollback-source-file ( file -- )
- dup source-file-definitions new-definitions get [ union ] 2map
+ dup source-file-definitions new-definitions get [ assoc-union ] 2map
swap set-source-file-definitions ;
SYMBOL: file
source-file-definitions old-definitions set
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
-
-: outside-usages ( seq -- usages )
- dup [
- over usage
- [ dup pathname? not swap where and ] subset seq-diff
- ] curry { } map>assoc ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces strings arrays vectors sequences ;
+USING: kernel math namespaces strings arrays vectors sequences
+sets ;
IN: splitting
TUPLE: groups seq n sliced? ;
: check-groups 0 <= [ "Invalid group count" throw ] when ;
: <groups> ( seq n -- groups )
- dup check-groups f groups construct-boa ; inline
+ dup check-groups f groups boa ; inline
: <sliced-groups> ( seq n -- groups )
<groups> t over set-groups-sliced? ;
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup "\r\n" seq-intersect empty? [
+ dup "\r\n" intersect empty? [
1array
] [
"\n" split [
-USING: continuations kernel math namespaces strings sbufs
-tools.test sequences vectors arrays ;
+USING: continuations kernel math namespaces strings
+strings.private sbufs tools.test sequences vectors arrays memory
+prettyprint io.streams.null ;
IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test
+
+! Regressions
+[ ] [
+ [
+ 4 [
+ 100 [ drop "obdurak" clone ] map
+ gc
+ dup [
+ 1234 0 rot set-string-nth
+ ] each
+ 1000 [
+ 1000 f <array> drop
+ ] times
+ .
+ ] times
+ ] with-null-stream
+] unit-test
+
+[ t ] [
+ 10000 [
+ drop
+ 300 100 CHAR: \u123456
+ [ <string> clone resize-string first ] keep =
+ ] all?
+] unit-test
: >string ( seq -- str ) "" clone-like ;
-M: string new drop 0 <string> ;
+M: string new-sequence drop 0 <string> ;
INSTANCE: string sequence
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-arrays io.files vocabs.loader io sequences assocs ;
+generic.standard arrays io.files vocabs.loader io sequences
+assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class delegate slots... }" }
-{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } }
+{ $syntax "T{ class slots... }" }
+{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
$nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
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
+{ $description "Defines a new tuple class whose class word throws a new instance of the error." }
+{ $notes
+ "The following two snippets are equivalent:"
+ { $code
+ "ERROR: invalid-values x y ;"
+ ""
+ "TUPLE: invalid-values x y ;"
+ ": invalid-values ( x y -- * )"
+ " \\ invalid-values boa throw ;"
+ }
+} ;
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
-{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link construct-boa } "." }
+{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link boa } "." }
{ $examples
"Suppose the following tuple has been defined:"
{ $code "TUPLE: color red green blue ;" }
"The following two lines are equivalent:"
{ $code
"C: <color> color"
- ": <color> color construct-boa ;"
+ ": <color> color boa ;"
}
"In both cases, a word " { $snippet "<color>" } " is defined, which reads three values from the stack and creates a " { $snippet "color" } " instance having these values in the " { $snippet "red" } ", " { $snippet "green" } " and " { $snippet "blue" } " slots, respectively."
} ;
{ $syntax ">>" }
{ $description "Marks the end of a parse time code block." } ;
+HELP: call-next-method
+{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This is syntax sugar around " { $link (call-next-method) } ". The following two lines are equivalent:"
+ { $code
+ "M: my-class my-generic ... call-next-method ... ;"
+ "M: my-class my-generic ... \\ my-class \\ my-generic (call-next-method) ... ;"
+ }
+"In most cases, this word should be called with the original input values on the stack. Calling it with other values is usually a sign of poor design." }
+{ $errors
+ "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
+} ;
+
+{ POSTPONE: call-next-method (call-next-method) next-method } related-words
+
{ POSTPONE: << POSTPONE: >> } related-words
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape drop ] }
- { [ t ] [ name>char-hook get call ] }
+ [ name>char-hook get call ]
} cond parsed
] define-syntax
"C:" [
CREATE-WORD
scan-word dup check-tuple
- [ construct-boa ] curry define-inline
+ [ boa ] curry define-inline
] define-syntax
"ERROR:" [
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
-"Reading environment variables:"
-{ $subsection os-env }
-{ $subsection os-envs }
+{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ARTICLE: "cpu" "Processor Detection"
+ARTICLE: "environment-variables" "Environment variables"
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ARTICLE: "cpu" "Processor detection"
"Processor detection:"
{ $subsection cpu }
"Supported processors:"
"Processor families:"
{ $subsection x86 } ;
-ARTICLE: "os" "Operating System Detection"
+ARTICLE: "os" "Operating system detection"
"Operating system detection:"
{ $subsection os }
"Supported operating systems:"
HELP: set-os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
+{ $notes
+ "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-{ os-env os-envs set-os-envs } related-words
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
HELP: image
{ $values { "path" "a pathname string" } }
-USING: math tools.test system prettyprint namespaces kernel ;
+USING: math tools.test system prettyprint namespaces kernel
+strings sequences ;
IN: system.tests
os wince? [
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
+
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ f ] [ "factor-test-key-1" os-env ] unit-test
+
+[ ] [
+ 32766 CHAR: a <string> "factor-test-key-long" set-os-env
+] unit-test
+[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
+[ ] [ "factor-test-key-long" unset-os-env ] unit-test
{ $subsection resume }
{ $subsection resume-with } ;
-ARTICLE: "thread-state" "Thread-local state"
+ARTICLE: "thread-state" "Thread-local state and variables"
"Threads form a class of objects:"
{ $subsection thread }
"The current thread:"
{ $subsection tget }
{ $subsection tset }
{ $subsection tchange }
+"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
+$nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
IN: threads.tests
3 "x" set
] unit-test
[ f ] [ f get-global ] unit-test
+
+{ { 0 3 6 9 12 15 18 21 24 27 } } [
+ 10 [
+ 0 "i" tset
+ [
+ "i" [ yield 3 + ] tchange
+ ] times yield
+ "i" tget
+ ] parallel-map
+] unit-test
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes ;
+dlists assocs system combinators init boxes accessors ;
SYMBOL: initial-thread
! Thread-local storage
: tnamespace ( -- assoc )
- self dup thread-variables
- [ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
+ self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
: tget ( key -- value )
- self thread-variables at ;
+ self variables>> at ;
: tset ( value key -- )
tnamespace set-at ;
: tchange ( key quot -- )
- tnamespace change-at ; inline
+ tnamespace swap change-at ; inline
: threads 41 getenv ;
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
- thread-id threads key? ;
+ id>> threads key? ;
: check-unregistered
dup thread-registered?
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup thread-id threads set-at ;
+ check-unregistered dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered thread-id threads delete-at ;
+ check-registered id>> threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
PRIVATE>
+: new-thread ( quot name class -- thread )
+ new
+ swap >>name
+ swap >>quot
+ \ thread counter >>id
+ <box> >>continuation
+ [ ] >>exit-handler ; inline
+
: <thread> ( quot name -- thread )
- \ thread counter <box> [ ] {
- set-thread-quot
- set-thread-name
- set-thread-id
- set-thread-continuation
- set-thread-exit-handler
- } \ thread construct ;
+ \ thread new-thread ;
: run-queue 42 getenv ;
: sleep-queue 43 getenv ;
: resume ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-front ;
: resume-now ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-back ;
: resume-with ( obj thread -- )
- f over set-thread-state
+ f >>state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
- { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+ [ sleep-queue heap-peek nip millis [-] ]
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered dup r> sleep-queue heap-push*
- swap set-thread-sleep-entry ;
+ >>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: expire-sleep ( thread -- )
- f over set-thread-sleep-entry resume ;
+ f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
- f over set-thread-state
- thread-continuation box>
+ f >>state
+ continuation>> box>
continue-with
] if ;
PRIVATE>
: stop ( -- )
- self dup thread-exit-handler call
+ self dup exit-handler>> call
unregister-thread next ;
: suspend ( quot state -- obj )
[
- self thread-continuation >box
- self set-thread-state
+ self continuation>> >box
+ self (>>state)
self swap call next
] callcc1 2nip ; inline
millis + >integer sleep-until ;
: interrupt ( thread -- )
- dup thread-state [
- dup thread-sleep-entry [ sleep-queue heap-delete ] when*
- f over set-thread-sleep-entry
+ dup state>> [
+ dup sleep-entry>> [ sleep-queue heap-delete ] when*
+ f >>sleep-entry
dup resume
] when drop ;
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
- thread-quot [ call stop ] call-clear
+ quot>> [ call stop ] call-clear
] 1 (throw)
] "spawn" suspend 2drop ;
<min-heap> 43 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
- <box> over set-thread-continuation
- f over set-thread-state
+ <box> >>continuation
+ f >>state
dup register-thread
set-self ;
100 >array dup >vector <reversed> >array >r reverse r> =
] unit-test
-[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
+[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
<PRIVATE
: array>vector ( array length -- vector )
- vector construct-boa ; inline
+ vector boa ; inline
PRIVATE>
dup array? [ dup length array>vector ] [ >vector ] if
] unless ;
-M: vector new drop [ f <array> ] keep >fixnum array>vector ;
+M: vector new
-sequence drop [ f <array> ] keep >fixnum array>vector ;
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs ;
+debugger compiler.units tools.vocabs accessors ;
! This vocab should not exist, but just in case...
[ ] [
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ [ no-word-error? ] is? ] must-fail-with
+] [ error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
] with-compilation-unit
] unit-test
+[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
+
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
[ 3 ] [ "count-me" get-global ] unit-test
TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
- vocab-link construct-boa ;
+ vocab-link boa ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;
HELP: gensym
{ $values { "word" word } }
-{ $description "Creates an uninterned word that is not equal to any other word in the system. Gensyms have an automatically-generated name based on a prefix and an incrementing counter." }
+{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
-io.streams.string ;
+io.streams.string accessors ;
IN: words.tests
[ 4 ] [
] when*
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
-[ [ undefined? ] is? ] must-fail-with
+[ error>> undefined? ] must-fail-with
[ ] [
"IN: words.tests GENERIC: symbol-generic" eval
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
-quotations assocs hashtables sorting math.parser words.private
-vocabs combinators ;
+quotations assocs hashtables sorting words.private vocabs ;
IN: words
: word ( -- word ) \ word get-global ;
GENERIC: crossref? ( word -- ? )
M: word crossref?
- {
- { [ dup "forgotten" word-prop ] [ f ] }
- { [ dup word-vocabulary ] [ t ] }
- { [ t ] [ f ] }
- } cond nip ;
+ dup "forgotten" word-prop [
+ drop f
+ ] [
+ word-vocabulary >boolean
+ ] if ;
+
+GENERIC: compiled-crossref? ( word -- ? )
+
+M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop crossref? ] assoc-subset
+ [ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
-M: word redefined* ( word -- )
- { "inferred-effect" "no-effect" } reset-props ;
+<PRIVATE
-SYMBOL: changed-words
+SYMBOL: visited
-: changed-word ( word -- )
- dup changed-words get
- [ no-compilation-unit ] unless*
- set-at ;
+: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ dup visited get set-at ]
+ [
+ crossref get at keys [ word? ] subset [
+ reset-on-redefine [ word-prop ] with contains?
+ ] subset
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+PRIVATE>
+
+: redefined ( word -- )
+ H{ } clone visited [ (redefined) ] with-variable ;
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
- dup changed-word
+ dup changed-definition
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
{ "methods" "combination" "default-method" } reset-props ;
: gensym ( -- word )
- "G:" \ gensym counter number>string append f <word> ;
+ "( gensym )" f <word> ;
: define-temp ( quot -- word )
gensym dup rot define ;
pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm )
- check-alarm <box> alarm construct-boa ;
+ check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup alarm-time alarms get-global heap-push*
--- /dev/null
+Non-core array words
--- /dev/null
+collections
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element construct-empty ;
+: <element> element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
TUPLE: tag value ;
-: <tag> ( -- <tag> ) 4 tag construct-boa ;
+: <tag> ( -- <tag> ) 4 tag boa ;
: with-ber ( quot -- )
[
: insert ( value variable -- ) namespace insert-at ;
-: 2seq>assoc ( keys values exemplar -- assoc )
- >r 2array flip r> assoc-like ;
-
: generate-key ( assoc -- str )
>r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
"benchmark.dispatch1" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
- my-classes [ construct-empty ] map ;
+ my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects
"benchmark.dispatch5" words [ tuple-class? ] subset ;\r
\r
: a-bunch-of-objects ( -- seq )\r
- my-classes [ construct-empty ] map ;\r
+ my-classes [ new ] map ;\r
\r
: dispatch-benchmark ( -- )\r
1000000 a-bunch-of-objects\r
: foo 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
M: check< summary drop "Number exceeds upper bound" ;
: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< construct-boa throw ] if ;
+ 2dup < [ drop ] [ \ check< boa throw ] if ;
: ?check ( length -- )
safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
{ [ os unix? ] [ "random.unix" require ] }
} cond
-! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
-[ millis <mersenne-twister> random-generator set-global ]
-"generator.random" add-init-hook
+[
+ [ 32 random-bits ] with-system-random
+ <mersenne-twister> random-generator set-global
+] "generator.random" add-init-hook
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+USING: bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: muon
+
+ { $class-description
+ "The muon is a colorful particle with an entangled friend."
+ "It draws both itself and its horizontally symmetric partner."
+ "A high range of speed and almost no speed decay allow the"
+ "muon to reach the extents of the window, often forming rings"
+ "where theta has decayed but speed remains stable. The result"
+ "is color almost everywhere in the general direction of collision,"
+ "stabilized into fuzzy rings." } ;
+
+HELP: quark
+
+ { $class-description
+ "The quark draws as a translucent black. Their large numbers"
+ "create fields of blackness overwritten only by the glowing shadows of "
+ "Hadrons. "
+ "quarks are allowed to accelerate away with speed decay values above 1.0. "
+ "Each quark has an entangled friend. Both particles are drawn identically,"
+ "mirrored along the y-axis." } ;
+
+HELP: hadron
+
+ { $class-description
+ "Hadrons collide from totally random directions. "
+ "Those hadrons that do not exit the drawing area, "
+ "tend to stabilize into perfect circular orbits. "
+ "Each hadron draws with a slight glowing emboss. "
+ "The hadron itself is not drawn." } ;
+
+HELP: axion
+
+ { $class-description
+ "The axion particle draws a bold black path. Axions exist "
+ "in a slightly higher dimension and as such are drawn with "
+ "elevated embossed shadows. Axions are quick to stabilize "
+ "and fall into single pixel orbits axions automatically "
+ "recollide themselves after stabilizing." } ;
+
+{ muon quark hadron axion } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber" "Bubble Chamber"
+
+ { $subsection "bubble-chamber-introduction" }
+ { $subsection "bubble-chamber-particles" }
+ { $subsection "bubble-chamber-author" }
+ { $subsection "bubble-chamber-running" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-introduction" "Introduction"
+
+"The Bubble Chamber is a generative painting system of imaginary "
+"colliding particles. A single super-massive collision produces a "
+"discrete universe of four particle types. Particles draw their "
+"positions over time as pixel exposures. " ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-particles" "Particles"
+
+"Four types of particles exist. The behavior and graphic appearance of "
+"each particle type is unique."
+
+ { $subsection muon }
+ { $subsection quark }
+ { $subsection hadron }
+ { $subsection axion } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-author" "Author"
+
+ "Bubble Chamber was created by Jared Tarbell. "
+ "It was originally implemented in Processing. "
+ "It was ported to Factor by Eduardo Cavazos. "
+ "The original work is on display here: "
+ { $url
+ "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-running" "How to use"
+
+ "After you run the vocabulary, a window will appear. Click the "
+ "mouse in a random area to fire 11 particles of each type. "
+ "Another way to fire particles is to press the "
+ "spacebar. This fires all the particles." ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces sequences random math math.constants math.libm vars
+ ui
+ processing
+ processing.gadget
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: particles muons quarks hadrons axions ;
+
+VAR: boom
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-all ( -- )
+
+ 2 pi * 1random >collision-theta
+
+ particles> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one ( -- )
+
+ dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+
+ hadrons> random collide
+ quarks> random collide
+ muons> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-pressed ( -- )
+ boom on
+ 1 background ! kludge
+ 11 [ drop collide-one ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-released ( -- )
+ key " " =
+ [
+ boom on
+ 1 background
+ collide-all
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- )
+
+ 1000 1000 size*
+
+ [
+ 1 background
+ no-stroke
+
+ 1789 [ drop <muon> ] map >muons
+ 1300 [ drop <quark> ] map >quarks
+ 1000 [ drop <hadron> ] map >hadrons
+ 111 [ drop <axion> ] map >axions
+
+ muons> quarks> hadrons> axions> 3append append >particles
+
+ collide-one
+ ] setup
+
+ [
+ boom>
+ [ particles> [ move ] each ]
+ when
+ ] draw
+
+ [ mouse-pressed ] button-down
+ [ key-released ] key-up ;
+
+: go ( -- ) [ bubble-chamber run ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel math accessors combinators.cleave vars ;
+
+IN: bubble-chamber.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: collision-theta
+
+: dim ( -- dim ) 1000 ;
+
+: center ( -- point ) dim 2 / dup {2} ; foldable
--- /dev/null
+
+USING: kernel sequences random accessors multi-methods
+ math math.constants math.ranges math.points combinators.cleave
+ processing bubble-chamber.common bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.axion
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: axion < particle ;
+
+: <axion> ( -- axion ) axion new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { axion }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { axion }
+
+ { 0.06 0.59 } stroke
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel random math math.constants math.points accessors multi-methods
+ processing
+ processing.color
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.hadron
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: hadron < particle ;
+
+: <hadron> ( -- hadron ) hadron new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { hadron }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ 0 1 0 <rgb> >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { hadron }
+
+ { 1 0.11 } stroke
+ dup pos>> 1 v-y point
+
+ { 0 0.11 } stroke
+ dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: kernel sequences math math.constants accessors
+ processing
+ processing.color ;
+
+IN: bubble-chamber.particle.muon.colors
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel arrays sequences random
+ math
+ math.ranges
+ math.functions
+ math.vectors
+ multi-methods accessors
+ combinators.cleave
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon.colors ;
+
+IN: bubble-chamber.particle.muon
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: muon < particle ;
+
+: <muon> ( -- muon ) muon new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { muon }
+
+ center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ collision-theta> -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { muon }
+
+ dup myc>> 0.16 >>alpha stroke
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha stroke
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences combinators
+ math math.vectors math.functions multi-methods
+ accessors combinators.cleave processing processing.color
+ bubble-chamber.common ;
+
+IN: bubble-chamber.particle
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x ( particle -- x ) pos>> first ;
+: y ( particle -- x ) pos>> second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: out-of-bounds? ( particle -- particle ? )
+ dup
+ { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
+ or or or ;
--- /dev/null
+
+USING: kernel arrays sequences random math accessors multi-methods
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.quark
+
+TUPLE: quark < particle ;
+
+: <quark> ( -- quark ) quark new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { quark }
+
+ center >>pos
+ collision-theta> -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { quark }
+
+ dup myc>> 0.13 >>alpha stroke
+ dup pos>> point
+
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: io.files io.launcher io.encodings.utf8 prettyprint
+ builder.util builder.common builder.child builder.release
+ builder.report builder.email builder.cleanup ;
+
+IN: builder.build
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: create-build-dir ( -- )
+ datestamp >stamp
+ build-dir make-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: enter-build-dir ( -- ) build-dir set-current-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clone-builds-factor ( -- )
+ { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-id ( -- )
+ "factor"
+ [ git-id "../git-id" utf8 [ . ] with-file-writer ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+ reset-status
+ create-build-dir
+ enter-build-dir
+ clone-builds-factor
+ record-id
+ build-child
+ release
+ report
+ email-report
+ cleanup ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build
\ No newline at end of file
-USING: kernel namespaces sequences splitting system combinators continuations
- parser io io.files io.launcher io.sockets prettyprint threads
- bootstrap.image benchmark vars bake smtp builder.util accessors
- io.encodings.utf8
- calendar
- tools.test
+USING: kernel debugger io.files threads calendar
builder.common
- builder.benchmark
- builder.release ;
+ builder.updates
+ builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : cd ( path -- ) current-directory set ;
-
-: cd ( path -- ) set-current-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prepare-build-machine ( -- )
- builds make-directory
- builds cd
- { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir ( -- )
- datestamp >stamp
- builds cd
- stamp> make-directory
- stamp> cd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
- { "git" "show" } utf8 <process-stream>
- [ readln ] with-stream " " split second ;
-
-: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gnu-make ( -- string )
- os { "freebsd" "openbsd" "netbsd" } member?
- [ "gmake" ]
- [ "make" ]
- if ;
-
-! : do-make-clean ( -- ) { "make" "clean" } try-process ;
-
-: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : make-vm ( -- desc )
-! <process>
-! { "make" } >>command
-! "../compile-log" >>stdout
-! +stdout+ >>stderr ;
-
-: make-vm ( -- desc )
- <process>
- { gnu-make } to-strings >>command
- "../compile-log" >>stdout
- +stdout+ >>stderr ;
-
-: do-make-vm ( -- )
- make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-image ( -- )
- builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
- builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bootstrap-cmd ( -- cmd )
- { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: bootstrap ( -- desc )
- <process>
- bootstrap-cmd >>command
- +closed+ >>stdin
- "../boot-log" >>stdout
- +stdout+ >>stderr
- 20 minutes >>timeout ;
-
-: do-bootstrap ( -- )
- bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
-
-: builder-test-cmd ( -- cmd )
- { "./factor" "-run=builder.test" } to-strings ;
-
-: builder-test ( -- desc )
- <process>
- builder-test-cmd >>command
- +closed+ >>stdin
- "../test-log" >>stdout
- +stdout+ >>stderr
- 120 minutes >>timeout ;
-
-: do-builder-test ( -- )
- builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: build-status
-
-: (build) ( -- )
-
- builds-check
-
- build-status off
-
- enter-build-dir
-
- "report" utf8
- [
- "Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
- "Build directory: " write cwd print
-
- git-clone [ "git clone failed" print ] run-or-bail
-
- "factor"
- [
- record-git-id
- do-make-clean
- do-make-vm
- copy-image
- do-bootstrap
- do-builder-test
- ]
- with-directory
-
- "test-log" delete-file
-
- "git id: " write "git-id" eval-file print nl
-
- "Boot time: " write "boot-time" eval-file milli-seconds>time print
- "Load time: " write "load-time" eval-file milli-seconds>time print
- "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
- "Did not pass load-everything: " print "load-everything-vocabs" cat
-
- "Did not pass test-all: " print "test-all-vocabs" cat
- "test-failures" cat
-
-! "test-failures" eval-file test-failures.
-
- "help-lint results:" print "help-lint" cat
-
- "Benchmarks: " print "benchmarks" eval-file benchmarks.
-
- nl
-
- show-benchmark-deltas
-
- "benchmarks" ".." copy-file-into
-
- maybe-release
- ]
- with-file-writer
-
- build-status on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-
-SYMBOL: builder-recipients
-
-: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
-
-: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-
-: send-builder-email ( -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- subject >>subject
- "./report" file>string >>body
- send-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- )
- { "bzip2" my-boot-image-name } to-strings run-process drop ;
-
-: build ( -- )
- [ (build) ] failsafe
- builds cd stamp> cd
- [ send-builder-email ] [ drop "not sending mail" . ] recover
- { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] failsafe ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: bootstrap.image.download
-
-: git-pull ( -- desc )
- {
- "git"
- "pull"
- "--no-summary"
- "git://factorcode.org/git/factor.git"
- "master"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull run-process drop
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- my-boot-image-name need-new-image?
- [ download-my-image t ]
- [ f ]
- if ;
-
: build-loop ( -- )
builds-check
[
- builds "/factor" append cd
- updates-available? new-image-available? or
- [ build ]
- when
+ builds/factor set-current-directory
+ new-code-available? [ build ] when
]
- failsafe
+ try
5 minutes sleep
build-loop ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: build-loop
+MAIN: build-loop
\ No newline at end of file
--- /dev/null
+
+USING: namespaces debugger io.files io.launcher accessors bootstrap.image
+ calendar builder.util builder.common ;
+
+IN: builder.child
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-vm ( -- )
+ <process>
+ gnu-make >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
+
+: copy-image ( -- )
+ builds-factor-image ".." copy-file-into
+ builds-factor-image "." copy-file-into ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-cmd ( -- cmd )
+ { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+
+: boot ( -- )
+ <process>
+ boot-cmd >>command
+ +closed+ >>stdin
+ "../boot-log" >>stdout
+ +stdout+ >>stderr
+ 60 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
+
+: test ( -- )
+ <process>
+ test-cmd >>command
+ +closed+ >>stdin
+ "../test-log" >>stdout
+ +stdout+ >>stderr
+ 240 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (build-child) ( -- )
+ make-clean
+ make-vm status-vm on
+ copy-image
+ boot status-boot on
+ test status-test on
+ status on ;
+
+: build-child ( -- )
+ "factor" set-current-directory
+ [ (build-child) ] try
+ ".." set-current-directory ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces io.files io.launcher bootstrap.image
+ builder.util builder.common ;
+
+IN: builder.cleanup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-debug
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+: delete-child-factor ( -- )
+ build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
+
+: cleanup ( -- )
+ builder-debug get f =
+ [
+ "test-log" delete-file
+ delete-child-factor
+ compress-image
+ ]
+ when ;
+
-USING: kernel namespaces io.files sequences vars ;
+USING: kernel namespaces sequences splitting
+ io io.files io.launcher io.encodings.utf8 prettyprint
+ vars builder.util ;
IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SYMBOL: upload-to-factorcode
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
SYMBOL: builds-dir
: builds ( -- path )
VAR: stamp
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir ( -- path ) builds stamp> append-path ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+ builds make-directory
+ builds
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: status-vm
+SYMBOL: status-boot
+SYMBOL: status-test
+SYMBOL: status-build
+SYMBOL: status-release
+SYMBOL: status
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-status ( -- )
+ { status-vm status-boot status-test status-build status-release status }
+ [ off ]
+ each ;
--- /dev/null
+
+USING: kernel namespaces accessors smtp builder.util builder.common ;
+
+IN: builder.email
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-from
+SYMBOL: builder-recipients
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
+
+: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
+
+: email-report ( -- )
+ <email>
+ builder-from get >>from
+ builder-recipients get >>to
+ subject >>subject
+ "report" file>string >>body
+ send-email ;
+
--- /dev/null
+
+USING: kernel combinators system sequences io.files io.launcher prettyprint
+ builder.util
+ builder.common ;
+
+IN: builder.release.archive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: base-name ( -- string )
+ { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
+
+: extension ( -- extension )
+ {
+ { [ os winnt? ] [ ".zip" ] }
+ { [ os macosx? ] [ ".dmg" ] }
+ { [ os unix? ] [ ".tar.gz" ] }
+ }
+ cond ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
+
+: macosx-archive-cmd ( -- cmd )
+ { "hdiutil" "create"
+ "-srcfolder" "factor"
+ "-fs" "HFS+"
+ "-volname" "factor"
+ archive-name } ;
+
+: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: archive-cmd ( -- cmd )
+ {
+ { [ os windows? ] [ windows-archive-cmd ] }
+ { [ os macosx? ] [ macosx-archive-cmd ] }
+ { [ os unix? ] [ unix-archive-cmd ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-archive ( -- ) archive-cmd to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: releases ( -- path )
+ builds "releases" append-path
+ dup exists? not
+ [ dup make-directory ]
+ when ;
+
+: save-archive ( -- ) archive-name releases move-file-into ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system namespaces sequences prettyprint io.files io.launcher
+ bootstrap.image
+ builder.util
+ builder.common ;
+
+IN: builder.release.branch
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+: refspec ( -- string ) "master:" branch-name append ;
+
+: push-to-clean-branch ( -- )
+ { "git" "push" "factorcode.org:/git/factor.git" refspec }
+ to-strings
+ try-process ;
+
+: upload-clean-image ( -- )
+ {
+ "scp"
+ my-boot-image-name
+ "factorcode.org:/var/www/factorcode.org/newsite/images/clean"
+ }
+ to-strings
+ try-process ;
+
+: (update-clean-branch) ( -- )
+ "factor"
+ [
+ push-to-clean-branch
+ upload-clean-image
+ ]
+ with-directory ;
+
+: update-clean-branch ( -- )
+ upload-to-factorcode get
+ [ (update-clean-branch) ]
+ when ;
-USING: kernel system namespaces sequences splitting combinators
- io io.files io.launcher
- bake combinators.cleave builder.common builder.util ;
+USING: kernel debugger system namespaces sequences splitting combinators
+ io io.files io.launcher prettyprint bootstrap.image
+ bake combinators.cleave
+ builder.util
+ builder.common
+ builder.release.branch
+ builder.release.tidy
+ builder.release.archive
+ builder.release.upload ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: releases ( -- path )
- builds "releases" append-path
- dup exists? not
- [ dup make-directory ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: common-files ( -- seq )
- {
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "boot.linux-ppc.image"
- "vm"
- "temp"
- "logs"
- ".git"
- ".gitignore"
- "Makefile"
- "unmaintained"
- "build-support"
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cpu- ( -- cpu ) cpu "." split "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: extension ( -- extension )
- os
- {
- { "linux" [ ".tar.gz" ] }
- { "winnt" [ ".zip" ] }
- { "macosx" [ ".dmg" ] }
- }
- case ;
-
-: archive-name ( -- string ) base-name extension append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
-
-: macosx-archive-cmd ( -- cmd )
- { "hdiutil" "create"
- "-srcfolder" "factor"
- "-fs" "HFS+"
- "-volname" "factor"
- archive-name } ;
-
-: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: archive-cmd ( -- cmd )
- {
- { [ windows? ] [ windows-archive-cmd ] }
- { [ macosx? ] [ macosx-archive-cmd ] }
- { [ unix? ] [ unix-archive-cmd ] }
- }
- cond ;
-
-: make-archive ( -- ) archive-cmd to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove-common-files ( -- )
- { "rm" "-rf" common-files } to-strings try-process ;
-
-: remove-factor-app ( -- )
- macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
-: platform ( -- string ) { os cpu- } to-strings "-" join ;
-
-: remote-location ( -- dest )
- "factorcode.org:/var/www/factorcode.org/newsite/downloads"
- platform
- append-path ;
-
-: upload ( -- )
- { "scp" archive-name remote-location } to-strings
- [ "Error uploading binary to factorcode" print ]
- run-or-bail ;
-
-: maybe-upload ( -- )
- upload-to-factorcode get
- [ upload ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : release ( -- )
-! "factor"
-! [
-! remove-factor-app
-! remove-common-files
-! ]
-! with-directory
-! make-archive
-! archive-name releases move-file-into ;
-
-: release ( -- )
- "factor"
- [
- remove-factor-app
- remove-common-files
- ]
- with-directory
+: (release) ( -- )
+ update-clean-branch
+ tidy
make-archive
- maybe-upload
- archive-name releases move-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ upload
+ save-archive
+ status-release on ;
-: release? ( -- ? )
- {
- "./load-everything-vocabs"
- "./test-all-vocabs"
- }
- [ eval-file empty? ]
- all? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: clean-build? ( -- ? )
+ { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
-: maybe-release ( -- ) release? [ release ] when ;
\ No newline at end of file
+: release ( -- ) [ clean-build? [ (release) ] when ] try ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system io.files io.launcher builder.util ;
+
+IN: builder.release.tidy
+
+: common-files ( -- seq )
+ {
+ "boot.x86.32.image"
+ "boot.x86.64.image"
+ "boot.macosx-ppc.image"
+ "boot.linux-ppc.image"
+ "vm"
+ "temp"
+ "logs"
+ ".git"
+ ".gitignore"
+ "Makefile"
+ "unmaintained"
+ "build-support"
+ } ;
+
+: remove-common-files ( -- )
+ { "rm" "-rf" common-files } to-strings try-process ;
+
+: remove-factor-app ( -- )
+ os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+
+: tidy ( -- )
+ "factor" [ remove-factor-app remove-common-files ] with-directory ;
--- /dev/null
+
+USING: kernel namespaces io io.files
+ builder.util
+ builder.common
+ builder.release.archive ;
+
+IN: builder.release.upload
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-location ( -- dest )
+ "factorcode.org:/var/www/factorcode.org/newsite/downloads"
+ platform
+ append-path ;
+
+: (upload) ( -- )
+ { "scp" archive-name remote-location } to-strings
+ [ "Error uploading binary to factorcode" print ]
+ run-or-bail ;
+
+: upload ( -- )
+ upload-to-factorcode get
+ [ (upload) ]
+ when ;
--- /dev/null
+
+USING: kernel namespaces debugger system io io.files io.sockets
+ io.encodings.utf8 prettyprint benchmark
+ builder.util builder.common ;
+
+IN: builder.report
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (report) ( -- )
+
+ "Build machine: " write host-name print
+ "CPU: " write cpu .
+ "OS: " write os .
+ "Build directory: " write build-dir print
+ "git id: " write "git-id" eval-file print nl
+
+ status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
+ status-boot get f = [ "boot-log" cat "Boot error" throw ] when
+ status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
+
+ "Boot time: " write "boot-time" eval-file milli-seconds>time print
+ "Load time: " write "load-time" eval-file milli-seconds>time print
+ "Test time: " write "test-time" eval-file milli-seconds>time print nl
+
+ "Did not pass load-everything: " print "load-everything-vocabs" cat
+
+ "Did not pass test-all: " print "test-all-vocabs" cat
+ "test-failures" cat
+
+ "help-lint results:" print "help-lint" cat
+
+ "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
+
+: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
\ No newline at end of file
-USING: kernel namespaces sequences assocs builder continuations
- vocabs vocabs.loader
- io
- io.files
- prettyprint
- tools.vocabs
- tools.test
- io.encodings.utf8
- combinators.cleave
+USING: kernel namespaces assocs
+ io.files io.encodings.utf8 prettyprint
help.lint
- bootstrap.stage2 benchmark builder.util ;
+ benchmark
+ bootstrap.stage2
+ tools.test tools.vocabs
+ builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-! : do-tests ( -- )
-! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-
: do-tests ( -- )
run-all-tests
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
-! : do-tests ( -- )
-! run-all-tests
-! "../test-all-vocabs" utf8
-! [
-! [ keys . ]
-! [ test-failures. ]
-! bi
-! ]
-! with-file-writer ;
-
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
--- /dev/null
+
+USING: kernel io.launcher bootstrap.image bootstrap.image.download
+ builder.util builder.common ;
+
+IN: builder.updates
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "--no-summary"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: updates-available? ( -- ? )
+ git-id
+ git-pull-cmd try-process
+ git-id
+ = not ;
+
+: new-image-available? ( -- ? )
+ my-boot-image-name need-new-image?
+ [ download-my-image t ]
+ [ f ]
+ if ;
+
+: new-code-available? ( -- ? )
+ updates-available?
+ new-image-available?
+ or ;
\ No newline at end of file
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
+ system
combinators sequences splitting quotations arrays strings tools.time
sequences.deep accessors assocs.lib
io.encodings.utf8
: to-string ( obj -- str )
dup class
{
- { string [ ] }
- { quotation [ call ] }
- { word [ execute ] }
- { fixnum [ number>string ] }
- { array [ to-strings concat ] }
+ { \ string [ ] }
+ { \ quotation [ call ] }
+ { \ word [ execute ] }
+ { \ fixnum [ number>string ] }
+ { \ array [ to-strings concat ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TUPLE: process* arguments stdin stdout stderr timeout ;
-
-! : <process*> process* construct-empty ;
-
-! : >desc ( process* -- desc )
-! H{ } clone
-! over arguments>> [ +arguments+ swap put-at ] when*
-! over stdin>> [ +stdin+ swap put-at ] when*
-! over stdout>> [ +stdout+ swap put-at ] when*
-! over stderr>> [ +stderr+ swap put-at ] when*
-! over timeout>> [ +timeout+ swap put-at ] when*
-! nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: failsafe ( quot -- ) [ drop ] recover ;
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+ os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+ { "git" "show" } utf8 <process-stream> [ readln ] with-stream
+ " " split second ;
numbers {
{ [ dup length 5 = ] [ 3 head pick push ] }
{ [ dup first 3 = ] [ 1 tail over push ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond (parse-model)
] when* ;
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
- bunny-dlist construct-boa ;
+ bunny-dlist boa ;
: <bunny-buffers> ( model -- geom )
{
]
[ first length 3 * ]
[ third length 3 * ]
- } cleave bunny-buffers construct-boa ;
+ } cleave bunny-buffers boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )
ERROR: cairo-error string ;
-: check-zero
+: check-zero ( n -- n )
dup zero? [
"PNG dimension is 0" cairo-error
] when ;
: cairo-png-error ( n -- )
{
- { [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] }
- { [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] }
- { [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] }
- { [ t ] [ drop ] }
+ { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
+ { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
+ { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
+ [ drop ]
} cond ;
: <png> ( path -- png )
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
- cairo-surface>array png construct-boa ;
+ cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
- { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
- { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
- drop TIME_ZONE_INFORMATION-Bias ] }
- { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
- drop
+ { TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
+ { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_DAYLIGHT [
[ TIME_ZONE_INFORMATION-Bias ]
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
] }
- } cond neg 60 /mod 0 ;
+ } case neg 60 /mod 0 ;
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-Stanford Bunny rendered with a cel-shading GLSL program
\ No newline at end of file
+++ /dev/null
-demos
-opengl
-glsl
\ No newline at end of file
TUPLE: channel receivers senders ;
: <channel> ( -- channel )
- V{ } clone V{ } clone channel construct-boa ;
+ V{ } clone V{ } clone channel boa ;
GENERIC: to ( value channel -- )
GENERIC: from ( channel -- value )
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
-USING: kernel sequences math sequences.private strings ;
+USING: kernel sequences math sequences.private strings
+accessors ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
- 0 circular construct-boa ;
+ 0 circular boa ;
: circular-wrap ( n circular -- n circular )
- [ circular-start + ] keep
- [ circular-seq length rem ] keep ; inline
+ [ start>> + ] keep
+ [ seq>> length rem ] keep ; inline
-M: circular length circular-seq length ;
+M: circular length seq>> length ;
-M: circular virtual@ circular-wrap circular-seq ;
+M: circular virtual@ circular-wrap seq>> ;
M: circular nth virtual@ nth ;
M: circular set-nth virtual@ set-nth ;
+M: circular virtual-seq seq>> ;
+
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
- circular-wrap set-circular-start ;
+ circular-wrap (>>start) ;
: push-circular ( elt circular -- )
- [ set-first ] keep 1 swap change-circular-start ;
+ [ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
-M: circular virtual-seq circular-seq ;
-
INSTANCE: circular virtual-sequence
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a b c ;"
- "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
+ "1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3"
}
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
+ "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4"
}
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
TUPLE: foo a b* c d* e f* ;
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
+[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien io kernel namespaces core-foundation cocoa.messages
-cocoa cocoa.classes cocoa.runtime sequences threads
-debugger init inspector kernel.private ;
+USING: alien io kernel namespaces core-foundation
+core-foundation.run-loop cocoa.messages cocoa cocoa.classes
+cocoa.runtime sequences threads debugger init inspector
+kernel.private ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ;
-: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
-
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error construct-boa throw ;
+ dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
"foo:"
"void"
{ "id" "SEL" "NSRect" }
- [ data-gc "x" set 2drop ]
+ [ gc "x" set 2drop ]
} ;
: test-foo
"NSArray"
"NSAutoreleasePool"
"NSBundle"
+ "NSDictionary"
"NSError"
"NSEvent"
"NSException"
"NSMenu"
"NSMenuItem"
+ "NSMutableDictionary"
"NSNib"
"NSNotification"
"NSNotificationCenter"
TUPLE: selector name object ;
-MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
+MEMO: <selector> ( name -- sel ) f \ selector boa ;
: selector ( selector -- alien )
dup selector-object expired? [
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
-} union alien>objc-types set-global
+} assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index* swap subseq
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- { [ t ] [ 2nip 1string objc>alien-types get at ] }
+ [ 2nip 1string objc>alien-types get at ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
-xml.writer xml.utilities kernel namespaces ;
+cocoa.messages cocoa.classes cocoa.application cocoa kernel
+namespaces io.backend ;
IN: cocoa.plists
-GENERIC: >plist ( obj -- tag )
+: assoc>NSDictionary ( assoc -- alien )
+ NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
+ [
+ [
+ spin [ <NSString> ] bi@ -> setObject:forKey:
+ ] curry assoc-each
+ ] keep ;
-M: string >plist "string" build-tag ;
-
-M: array >plist
- [ >plist ] map "array" build-tag* ;
-
-M: hashtable >plist
- >alist [ >r "key" build-tag r> >plist ] assoc-map concat
- "dict" build-tag* ;
-
-: build-plist ( obj -- tag )
- >plist 1array "plist" build-tag*
- dup { { "version" "1.0" } } update ;
-
-: plist>string ( obj -- string )
- build-plist build-xml xml>string ;
+: write-plist ( assoc path -- )
+ >r assoc>NSDictionary
+ r> normalize-path <NSString> 0 -> writeToFile:atomically:
+ [ "write-plist failed" throw ] unless ;
[ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ construct-empty ] curry swap [
+ [ new ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;
IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
-concurrency.mailboxes threads sequences ;\r
+concurrency.mailboxes threads sequences accessors ;\r
\r
[ [ drop ] parallel-each ] must-infer\r
[ [ ] parallel-map ] must-infer\r
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
-[ delegate "Even" = ] must-fail-with\r
+[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test\r
\r
: <count-down> ( n -- count-down )\r
dup 0 < [ "Invalid count for count down" throw ] when\r
- <promise> \ count-down construct-boa\r
+ <promise> \ count-down boa\r
dup count-down-check ;\r
\r
: count-down ( count-down -- )\r
TUPLE: exchanger thread object ;\r
\r
: <exchanger> ( -- exchanger )\r
- <box> <box> exchanger construct-boa ;\r
+ <box> <box> exchanger boa ;\r
\r
: exchange ( obj exchanger -- newobj )\r
dup exchanger-thread box-full? [\r
TUPLE: flag value? thread ;
-: <flag> ( -- flag ) f <box> flag construct-boa ;
+: <flag> ( -- flag ) f <box> flag boa ;
: raise-flag ( flag -- )
dup flag-value? [
TUPLE: lock threads owner reentrant? ;\r
\r
: <lock> ( -- lock )\r
- <dlist> f f lock construct-boa ;\r
+ <dlist> f f lock boa ;\r
\r
: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock construct-boa ;\r
+ <dlist> f t lock boa ;\r
\r
<PRIVATE\r
\r
TUPLE: rw-lock readers writers reader# writer ;\r
\r
: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock construct-boa ;\r
+ <dlist> <dlist> 0 f rw-lock boa ;\r
\r
<PRIVATE\r
\r
\r
\r
ARTICLE: "concurrency.mailboxes" "Mailboxes"\r
-"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."\r
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."\r
{ $subsection mailbox }\r
{ $subsection <mailbox> }\r
"Removing the first element:"\r
"Testing if a mailbox is empty:"\r
{ $subsection mailbox-empty? }\r
{ $subsection while-mailbox-empty } ;\r
+\r
+ABOUT: "concurrency.mailboxes"\r
IN: concurrency.mailboxes.tests\r
-USING: concurrency.mailboxes vectors sequences threads\r
-tools.test math kernel strings ;\r
+USING: concurrency.mailboxes concurrency.count-downs vectors\r
+sequences threads tools.test math kernel strings namespaces\r
+continuations calendar ;\r
\r
[ V{ 1 2 3 } ] [\r
0 <vector>\r
"junk2" over mailbox-put\r
mailbox-get\r
] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ [ "m" get mailbox-get drop ]\r
+ [ drop "d" get count-down ] recover\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ "m" get wait-for-close\r
+ "d" get count-down\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
IN: concurrency.mailboxes\r
USING: dlists threads sequences continuations\r
namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions ;\r
+init system concurrency.conditions accessors ;\r
\r
-TUPLE: mailbox threads data ;\r
+TUPLE: mailbox threads data closed ;\r
+\r
+: check-closed ( mailbox -- )\r
+ closed>> [ "Mailbox closed" throw ] when ; inline\r
+\r
+M: mailbox dispose\r
+ t >>closed threads>> notify-all ;\r
\r
: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> mailbox construct-boa ;\r
+ <dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
- mailbox-data dlist-empty? ;\r
+ data>> dlist-empty? ;\r
\r
: mailbox-put ( obj mailbox -- )\r
- [ mailbox-data push-front ] keep\r
- mailbox-threads notify-all yield ;\r
+ [ data>> push-front ]\r
+ [ threads>> notify-all ] bi yield ;\r
+\r
+: wait-for-mailbox ( mailbox timeout -- )\r
+ >r threads>> r> "mailbox" wait ;\r
\r
: block-unless-pred ( mailbox timeout pred -- )\r
- pick mailbox-data over dlist-contains? [\r
+ pick check-closed\r
+ pick data>> over dlist-contains? [\r
3drop\r
] [\r
- >r over mailbox-threads over "mailbox" wait r>\r
- block-unless-pred\r
+ >r 2dup wait-for-mailbox r> block-unless-pred\r
] if ; inline\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
+ over check-closed\r
over mailbox-empty? [\r
- over mailbox-threads over "mailbox" wait\r
- block-if-empty\r
+ 2dup wait-for-mailbox block-if-empty\r
] [\r
drop\r
] if ;\r
\r
: mailbox-peek ( mailbox -- obj )\r
- mailbox-data peek-back ;\r
+ data>> peek-back ;\r
\r
: mailbox-get-timeout ( mailbox timeout -- obj )\r
- block-if-empty mailbox-data pop-back ;\r
+ block-if-empty data>> pop-back ;\r
\r
: mailbox-get ( mailbox -- obj )\r
f mailbox-get-timeout ;\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
[ dup mailbox-empty? ]\r
- [ dup mailbox-data pop-back ]\r
+ [ dup data>> pop-back ]\r
[ ] unfold nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
3dup block-unless-pred\r
- nip >r mailbox-data r> delete-node-if ; inline\r
+ nip >r data>> r> delete-node-if ; inline\r
\r
: mailbox-get? ( mailbox pred -- obj )\r
f swap mailbox-get-timeout? ; inline\r
\r
-TUPLE: linked-error thread ;\r
+: wait-for-close-timeout ( mailbox timeout -- )\r
+ over closed>>\r
+ [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;\r
+\r
+: wait-for-close ( mailbox -- )\r
+ f wait-for-close-timeout ;\r
+\r
+TUPLE: linked-error error thread ;\r
\r
-: <linked-error> ( error thread -- linked )\r
- { set-delegate set-linked-error-thread }\r
- linked-error construct ;\r
+C: <linked-error> linked-error\r
\r
: ?linked dup linked-error? [ rethrow ] when ;\r
\r
-TUPLE: linked-thread supervisor ;\r
+TUPLE: linked-thread < thread supervisor ;\r
\r
M: linked-thread error-in-thread\r
- [ <linked-error> ] keep\r
- linked-thread-supervisor mailbox-put ;\r
+ [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
\r
: <linked-thread> ( quot name mailbox -- thread' )\r
- >r <thread> linked-thread construct-delegate r>\r
- over set-linked-thread-supervisor ;\r
+ >r linked-thread new-thread r> >>supervisor ;\r
\r
: spawn-linked-to ( quot name mailbox -- thread )\r
<linked-thread> [ (spawn) ] keep ;\r
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
-ARTICLE: { "concurrency" "messaging" } "Mailboxes"
+ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
$nl
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
{ $subsection receive }
{ $subsection receive-timeout }
{ $subsection receive-if }
-{ $subsection receive-if-timeout } ;
+{ $subsection receive-if-timeout }
+{ $see-also "concurrency.mailboxes" } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
-match quotations concurrency.messaging concurrency.mailboxes ;
+match quotations concurrency.messaging concurrency.mailboxes
+concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
"crash" throw
] "Linked test" spawn-linked drop
receive
-] [ delegate "crash" = ] must-fail-with
+] [ error>> "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment
[ value , self , ] { } make "counter" get send
receive
exit "counter" get send
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Not yet
+
+! 1 <count-down> "c" set
+
+! [
+! "c" get count-down
+! receive drop
+! ] "Bad synchronous send" spawn "t" set
+
+! [ 3 "t" get send-synchronous ] must-fail
\ No newline at end of file
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous construct-boa ;\r
+ self 256 random-bits synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
: <reply> ( data synchronous -- reply )\r
- synchronous-tag \ reply construct-boa ;\r
+ synchronous-tag \ reply boa ;\r
\r
: synchronous-reply? ( response synchronous -- ? )\r
over reply?\r
TUPLE: promise mailbox ;\r
\r
: <promise> ( -- promise )\r
- <mailbox> promise construct-boa ;\r
+ <mailbox> promise boa ;\r
\r
: promise-fulfilled? ( promise -- ? )\r
promise-mailbox mailbox-empty? not ;\r
\r
: <semaphore> ( n -- semaphore )\r
dup 0 < [ "Cannot have semaphore with negative count" throw ] when\r
- <dlist> semaphore construct-boa ;\r
+ <dlist> semaphore boa ;\r
\r
: wait-to-acquire ( semaphore timeout -- )\r
>r semaphore-threads r> "semaphore" wait ;\r
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel
-sequences sequences.lib assocs system sorting math.parser ;
+sequences sequences.lib assocs system sorting math.parser
+sets ;
IN: contributors
: changelog ( -- authors )
- image parent-directory cd
- "git-log --pretty=format:%an" <process-stream> lines ;
+ image parent-directory [
+ "git-log --pretty=format:%an" <process-stream> lines
+ ] with-directory ;
: patch-counts ( authors -- assoc )
dup prune
TYPEDEF: void* CFStringRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
-TYPEDEF: void* CFRunLoopRef
TYPEDEF: bool Boolean
TYPEDEF: int CFIndex
+TYPEDEF: int SInt32
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
] [
"Cannot load bundled named " prepend throw
] ?if ;
-
-FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences
-namespaces assocs init continuations core-foundation ;
+namespaces assocs init accessors continuations combinators
+core-foundation core-foundation.run-loop ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
[
event-stream-callbacks global
- [ [ drop expired? not ] assoc-subset ] change-at
- 1 \ event-stream-counter set-global
+ [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
] "core-foundation" add-init-hook
-event-stream-callbacks global [ H{ } assoc-like ] change-at
-
: add-event-source-callback ( quot -- id )
event-stream-counter <alien>
[ event-stream-callbacks get set-at ] keep ;
}
"cdecl" [
[ >event-triple ] 3curry map
- swap event-stream-callbacks get at call
- drop
+ swap event-stream-callbacks get at
+ dup [ call drop ] [ 3drop ] if
] alien-callback ;
-TUPLE: event-stream info handle ;
+TUPLE: event-stream info handle closed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
- event-stream construct-boa ;
+ f event-stream boa ;
M: event-stream dispose
- dup event-stream-info remove-event-source-callback
- event-stream-handle dup disable-event-stream
- FSEventStreamRelease ;
+ dup closed>> [ drop ] [
+ t >>closed
+ {
+ [ info>> remove-event-source-callback ]
+ [ handle>> disable-event-stream ]
+ [ handle>> FSEventStreamInvalidate ]
+ [ handle>> FSEventStreamRelease ]
+ } cleave
+ ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel threads init namespaces alien
+core-foundation ;
+IN: core-foundation.run-loop
+
+: kCFRunLoopRunFinished 1 ; inline
+: kCFRunLoopRunStopped 2 ; inline
+: kCFRunLoopRunTimedOut 3 ; inline
+: kCFRunLoopRunHandledSource 4 ; inline
+
+TYPEDEF: void* CFRunLoopRef
+
+FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
+
+FUNCTION: SInt32 CFRunLoopRunInMode (
+ CFStringRef mode,
+ CFTimeInterval seconds,
+ Boolean returnAfterSourceHandled
+) ;
+
+: CFRunLoopDefaultMode ( -- alien )
+ #! Ugly, but we don't have static NSStrings
+ \ CFRunLoopDefaultMode get-global dup expired? [
+ drop
+ "kCFRunLoopDefaultMode" <CFString>
+ dup \ CFRunLoopDefaultMode set-global
+ ] when ;
+
+: run-loop-thread ( -- )
+ CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
+ kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
+ run-loop-thread ;
+
+: start-run-loop-thread ( -- )
+ [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
+
+[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
TUPLE: coroutine resumecc exitcc ;
: cocreate ( quot -- co )
- coroutine construct-empty
+ coroutine new
dup current-coro associate
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
[ HEX: 10 swap set-cpu-last-interrupt ] keep
0 swap set-cpu-cycles ;
-: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
+: <cpu> ( -- cpu ) cpu new dup reset ;
: (load-rom) ( n ram -- )
read1 [ ! n ram ch
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
seq>2seq [ byte-array>sha1 ] bi@
- swap 2seq>seq ;
+ 2seq>seq ;
+++ /dev/null
-USING: kernel math test namespaces crypto crypto-internals ;
-
-[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
-[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test
-
update-statements
delete-statements ;
-: <db> ( handle -- obj )
- H{ } clone H{ } clone H{ } clone
- db construct-boa ;
+: construct-db ( class -- obj )
+ new
+ H{ } clone >>insert-statements
+ H{ } clone >>update-statements
+ H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db )
-GENERIC: db-open ( db -- )
+
+: make-db ( seq class -- db )
+ construct-db make-db* ;
+
+GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
-: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
handle>> db-close
] with-variable ;
+! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-TUPLE: nonthrowable-statement ;
+TUPLE: simple-statement < statement ;
+TUPLE: prepared-statement < statement ;
+TUPLE: nonthrowable-statement < statement ;
+TUPLE: throwable-statement < statement ;
+
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
nonthrowable-statement construct-delegate
] if ;
-MIXIN: throwable-statement
-INSTANCE: statement throwable-statement
-INSTANCE: simple-statement throwable-statement
-INSTANCE: prepared-statement throwable-statement
-
TUPLE: result-set sql in-params out-params handle n max ;
-: <statement> ( sql in out -- statement )
- { (>>sql) (>>in-params) (>>out-params) } statement construct ;
+
+: construct-statement ( sql in out class -- statement )
+ new
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
dup #rows >>max
0 >>n drop ;
-: <result-set> ( query handle tuple -- result-set )
- >r >r { sql>> in-params>> out-params>> } get-slots r>
- { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
- construct r> construct-delegate ;
-
+: construct-result-set ( query handle class -- result-set )
+ new
+ swap >>handle
+ >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- )
- >r make-db dup db-open db r>
+ >r make-db db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set )
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
-: mysql-connect ( mysql-connection -- )
- new-mysql over set-mysql-db-handle
- dup {
- mysql-db-handle
- mysql-db-host
- mysql-db-user
- mysql-db-password
- mysql-db-db
- mysql-db-port
- } get-slots f 0 mysql_real_connect mysql-error ;
+! : mysql-connect ( mysql-connection -- )
+ ! new-mysql over set-mysql-db-handle
+ ! dup {
+ ! mysql-db-handle
+ ! mysql-db-host
+ ! mysql-db-user
+ ! mysql-db-password
+ ! mysql-db-db
+ ! mysql-db-port
+ ! } get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
- drop ;
+ ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-namespaces.lib ;
+namespaces.lib accessors ;
IN: db.postgresql
-TUPLE: postgresql-db host port pgopts pgtty db user pass ;
-TUPLE: postgresql-statement ;
-INSTANCE: postgresql-statement throwable-statement
-TUPLE: postgresql-result-set ;
+TUPLE: postgresql-db < db
+ host port pgopts pgtty db user pass ;
+
+TUPLE: postgresql-statement < throwable-statement ;
+
+TUPLE: postgresql-result-set < result-set ;
+
: <postgresql-statement> ( statement in out -- postgresql-statement )
- <statement>
- postgresql-statement construct-delegate ;
+ postgresql-statement construct-statement ;
M: postgresql-db make-db* ( seq tuple -- db )
- >r first4 r> [
- {
- set-postgresql-db-host
- set-postgresql-db-user
- set-postgresql-db-pass
- set-postgresql-db-db
- } set-slots
- ] keep ;
-
-M: postgresql-db db-open ( db -- )
- dup {
- postgresql-db-host
- postgresql-db-port
- postgresql-db-pgopts
- postgresql-db-pgtty
- postgresql-db-db
- postgresql-db-user
- postgresql-db-pass
- } get-slots connect-postgres <db> swap set-delegate ;
+ >r first4 r>
+ swap >>db
+ swap >>pass
+ swap >>user
+ swap >>host ;
+
+M: postgresql-db db-open ( db -- db )
+ dup {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ db>> ]
+ [ user>> ]
+ [ pass>> ]
+ } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
- db-handle PQfinish ;
+ handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
- result-set-handle PQntuples ;
+ handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
- result-set-handle PQnfields ;
+ handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ;
] [
dup do-postgresql-statement
] if*
- postgresql-result-set <result-set>
+ postgresql-result-set construct-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
- >r db get db-handle "" r>
+ >r db get handle>> "" r>
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
{ offset 40 }
{ limit 20 }
} ;
-
-
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
- { [ t ] [ T{ no-sql-match } throw ] }
+ [ T{ no-sql-match } throw ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
{
{ [ dup SQLITE_OK = ] [ drop ] }
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
- { [ t ] [ sqlite-error ] }
+ [ sqlite-error ]
} cond ;
: sqlite-open ( filename -- db )
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
-io namespaces.lib ;
-USE: tools.walker
+io namespaces.lib accessors ;
IN: db.sqlite
-TUPLE: sqlite-db path ;
+TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db )
- [ set-sqlite-db-path ] keep ;
+ swap >>path ;
-M: sqlite-db db-open ( db -- )
- dup sqlite-db-path sqlite-open <db>
- swap set-delegate ;
+M: sqlite-db db-open ( db -- db )
+ [ path>> sqlite-open ] [ swap >>handle ] bi ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
-TUPLE: sqlite-statement ;
-INSTANCE: sqlite-statement throwable-statement
+TUPLE: sqlite-statement < throwable-statement ;
-TUPLE: sqlite-result-set has-more? ;
+TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
- {
- set-statement-sql
- set-statement-in-params
- set-statement-out-params
- } statement construct
- sqlite-statement construct-delegate ;
+ sqlite-statement construct-statement ;
: sqlite-maybe-prepare ( statement -- statement )
- dup statement-handle [
- [
- delegate
- db get db-handle over statement-sql sqlite-prepare
- swap set-statement-handle
- ] keep
+ dup handle>> [
+ db get handle>> over sql>> sqlite-prepare
+ >>handle
] unless ;
M: sqlite-statement dispose ( statement -- )
- statement-handle
+ handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
- f swap set-result-set-handle ;
+ f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
- sqlite-maybe-prepare
- statement-handle sqlite-reset ;
+ sqlite-maybe-prepare handle>> sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
M: sqlite-statement bind-tuple ( tuple statement -- )
[
- statement-in-params
+ in-params>>
[
- [ sql-spec-column-name ":" prepend ]
- [ sql-spec-slot-name rot get-slot-named ]
- [ sql-spec-type ] tri 3array
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri 3array
] with map
] keep
bind-statement ;
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
- result-set-handle sqlite-#columns ;
+ handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
- >r result-set-handle r> sqlite-column ;
+ [ handle>> ] [ sqlite-column ] bi* ;
M: sqlite-result-set row-column-typed ( result-set n -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r result-set-handle r> r> sqlite-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
- [ result-set-handle sqlite-next ] keep
- set-sqlite-result-set-has-more? ;
+ dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? )
- sqlite-result-set-has-more? ;
+ has-more?>> ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
- dup statement-handle sqlite-result-set <result-set>
+ dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
"insert into " 0% 0%
"(" 0%
maybe-remove-id
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
: where-primary-key% ( specs -- )
" where " 0%
- find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
: where-clause ( specs -- )
" where " 0%
- [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+ [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
0%
" set " 0%
dup remove-id
- [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
"delete from " 0% 0%
" where " 0%
find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
+ dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- )
- dup 1, sql-spec-column-name ":" prepend 0% ;
+ dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
+ [ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
+ [ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
-! [ assigned-person-schema test-repeated-insert ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-repeated-insert ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-sqlite
+ [ native-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
- dup first sql-spec-class construct-empty [
+ dup first sql-spec-class new [
[
>r sql-spec-slot-name r> set-slot-named
] curry 2each
[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
-[ [ baz see ] with-string-writer ] unit-test
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint combinators.lib math hashtables ;
+vectors definitions prettyprint combinators.lib math hashtables sets ;
IN: delegate
: protocol-words ( protocol -- words )
protocol-consult keys ;
: lost-words ( protocol wordlist -- lost-words )
- >r protocol-words r> seq-diff ;
+ >r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- )
values [ drop protocol-users ] [ lost-words ] 2bi
forget-all-methods ;
: added-words ( protocol wordlist -- added-words )
- swap protocol-words seq-diff ;
+ swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
IN: delegate.protocols
PROTOCOL: sequence-protocol
- clone clone-like like new new-resizable nth nth-unsafe
+ clone clone-like like new-sequence new-resizable nth nth-unsafe
set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
- where set-where forget uses redefined*
+ where set-where forget uses
synopsis* definer definition ;
-
-PROTOCOL: prettyprint-section-protocol
- section-fits? indent-section? unindent-first-line?
- newline-after? short-section? short-section long-section
- <section> delegate>block add-section ;
TUPLE: dummy-obj destroyed? ;
-: <dummy-obj> dummy-obj construct-empty ;
+: <dummy-obj> dummy-obj new ;
TUPLE: dummy-destructor obj ;
] if ;
: <destructor> ( obj -- newobj )
- f destructor construct-boa ;
+ f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
TUPLE: vertex value edges ;
: <digraph> ( -- digraph )
- digraph construct-empty H{ } clone over set-delegate ;
+ digraph new H{ } clone over set-delegate ;
: <vertex> ( value -- vertex )
- V{ } clone vertex construct-boa ;
+ V{ } clone vertex boa ;
: add-vertex ( key value digraph -- )
>r <vertex> swap r> set-at ;
--- /dev/null
+collections
--- /dev/null
+Eric Mertens
--- /dev/null
+USING: accessors arrays hints kernel locals math sequences ;
+
+IN: disjoint-set
+
+<PRIVATE
+
+TUPLE: disjoint-set parents ranks counts ;
+
+: count ( a disjoint-set -- n )
+ counts>> nth ; inline
+
+: add-count ( p a disjoint-set -- )
+ [ count [ + ] curry ] keep counts>> swap change-nth ; inline
+
+: parent ( a disjoint-set -- p )
+ parents>> nth ; inline
+
+: set-parent ( p a disjoint-set -- )
+ parents>> set-nth ; inline
+
+: link-sets ( p a disjoint-set -- )
+ [ set-parent ]
+ [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+ ranks>> nth ; inline
+
+: inc-rank ( a disjoint-set -- )
+ ranks>> [ 1+ ] change-nth ; inline
+
+: representative? ( a disjoint-set -- ? )
+ dupd parent = ; inline
+
+: representative ( a disjoint-set -- p )
+ 2dup representative? [ drop ] [
+ [ [ parent ] keep representative dup ] 2keep set-parent
+ ] if ;
+
+: representatives ( a b disjoint-set -- r r )
+ [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+ [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+ a b = zero [ a b < neg pos if ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( n -- disjoint-set )
+ [ >array ]
+ [ 0 <array> ]
+ [ 1 <array> ] tri
+ disjoint-set boa ;
+
+: equiv-set-size ( a disjoint-set -- n )
+ [ representative ] keep count ;
+
+: equiv? ( a b disjoint-set -- ? )
+ representatives = ; inline
+
+:: equate ( a b disjoint-set -- )
+ a b disjoint-set representatives
+ 2dup = [ 2drop ] [
+ 2dup disjoint-set ranks
+ [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+ disjoint-set link-sets
+ ] if ;
+
+HINTS: equate disjoint-set ;
+HINTS: representative disjoint-set ;
+HINTS: equiv-set-size disjoint-set ;
--- /dev/null
+An efficient implementation of the disjoint-set data structure
--- /dev/null
+collections
-rot {
{ [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ >r first 1- r> line-end ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
: (next-char) ( loc document quot -- loc )
-rot {
{ [ 2dup doc-end = ] [ drop ] }
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
M: char-elt prev-elt
[ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col )
- rot break-detector find-last*
- drop [ 1+ ] [ 0 ] if* ;
+ rot break-detector find-last* drop ?1+ ;
: (next-word) ( ? col str -- col )
[ rot break-detector find* drop ] keep
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting classes.tuple ;
+io.backend splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
: editor-restarts ( -- alist )
available-editors
- [ "Load " over append swap ] { } map>assoc ;
+ [ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
- \ no-edit-hook construct-empty
+ \ no-edit-hook new
editor-restarts throw-restarts
require ;
: edit-location ( file line -- )
- >r (normalize-path) "\\\\?\\" ?head drop r>
+ >r (normalize-path) r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
+GENERIC: find-parse-error ( error -- error' )
+
+M: parse-error find-parse-error
+ dup error>> find-parse-error [ ] [ ] ?if ;
+
+M: condition find-parse-error
+ error>> find-parse-error ;
+
+M: object find-parse-error
+ drop f ;
+
: :edit ( -- )
- error get delegates [ parse-error? ] find-last nip [
- dup parse-error-file source-file-path
- swap parse-error-line edit-location
+ error get find-parse-error [
+ [ file>> path>> ] [ line>> ] bi edit-location
] when* ;
: fix ( word -- )
- "Fixing " write dup pprint " and all usages..." print nl
- dup usage swap prefix [
- "Editing " write dup .
- "RETURN moves on to the next usage, C+d stops." print
- flush
- edit
- readln
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ usage ] keep prefix ] bi
+ [
+ [ "Editing " write . ]
+ [
+ "RETURN moves on to the next usage, C+d stops." print
+ flush
+ edit
+ readln
+ ] bi
] all? drop ;
! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating.fhtml io.files ;
+USING: http.server.templating http.server.templating.fhtml
+io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
- "misc/factor.vim.fgen" resource-path
+ "misc/factor.vim.fgen" resource-path <fhtml>
"misc/factor.vim" resource-path
template-convert ;
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
+[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
-html.elements xml.entities xmode.code2html splitting
-io.streams.string html peg.parsers html.elements sequences.deep
-unicode.categories ;
+USING: arrays io io.styles kernel memoize namespaces peg
+sequences strings html.elements xml.entities xmode.code2html
+splitting io.streams.string html peg.parsers html.elements
+sequences.deep unicode.categories ;
IN: farkup
+<PRIVATE
+
: delimiters ( -- string )
"*_^~%[-=|\\\n" ; inline
: render-code ( string mode -- string' )
>r string-lines r>
- [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+ [
+ [
+ H{ { wrap-margin f } } [
+ htmlize-lines
+ ] with-nesting
+ ] with-html-stream
+ ] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
[ "<p>" swap "</p>" 3array ] unless
] action ;
+PRIVATE>
+
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
drop 1quotation
] [
unclip {
- { , [ [ curry ] ((fry)) ] }
- { @ [ [ compose ] ((fry)) ] }
+ { \ , [ [ curry ] ((fry)) ] }
+ { \ @ [ [ compose ] ((fry)) ] }
! to avoid confusion, remove if fry goes core
- { namespaces:, [ [ curry ] ((fry)) ] }
+ { \ namespaces:, [ [ curry ] ((fry)) ] }
[ swap >r suffix r> (fry) ]
} case
TUPLE: cursortree cursors ;
: <cursortree> ( seq -- cursortree )
- <gb> cursortree
construct-empty tuck set-delegate <avl>
+ <gb> cursortree
new tuck set-delegate <avl>
over set-cursortree-cursors ;
GENERIC: cursortree-gb ( cursortree -- gb )
M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
+ cursor new tuck set-cursor-tree ;
: make-cursor ( cursortree pos cursor -- cursor )
>r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
+ left-cursor new make-cursor ;
: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
+ right-cursor new make-cursor ;
: cursors ( cursortree -- seq )
cursortree-cursors values concat ;
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
: <gb> ( seq -- gb )
- gb construct-empty
+ gb new
5 over set-gb-min-size
1.5 over set-gb-expand-factor
[ >r length r> set-gb-gap-start ] 2keep
+collections
collections sequences
IN: hardware-info.backend
HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
IN: hardware-info
: write-unit ( x n str -- )
- [ 2^ /i number>string write bl ] [ write ] bi* ;
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
: kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
{ [ os linux? ] [ "hardware-info.linux" ] }
{ [ os macosx? ] [ "hardware-info.macosx" ] }
- { [ t ] [ f ] }
+ [ f ]
} cond [ require ] when* >>
: hardware-report. ( -- )
"CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
USING: alien.c-types hardware-info kernel math namespaces
-windows windows.kernel32 hardware-info.backend ;
+windows windows.kernel32 hardware-info.backend system ;
IN: hardware-info.windows.ce
: memory-status ( -- MEMORYSTATUS )
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "\"mydata.dat\" dup file-info file-info-length ["
+ "\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
":errors - print 2 compiler errors."
":warnings - print 50 compiler warnings."
}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
{ $references
"To learn more about the compiler and static stack effect inference, read these articles:"
"compiler"
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
-"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
+"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
{ $references
{ }
"cli"
$nl
"Keep the following guidelines in mind to avoid losing your sense of balance:"
{ $list
- "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+ "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
"If your code looks repetitive, factor it some more."
"If after factoring, your code still looks repetitive, introduce combinators."
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
{ "Learn to use the " { $link "inference" } " tool." }
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
- "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
+ "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
$nl
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
{ $code "\"inference\" test" }
- "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
+ "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
collect-elements [ \ f or ] map ;
: help-path ( topic -- seq )
- [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
+ [ article-parent ] follow 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] with each ;
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
-quotations io.streams.byte-array io.encodings.string ;
+quotations io.streams.byte-array io.encodings.string
+classes.builtin parser ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+ { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
- { [ t ] [ (:help-multi) ] }
+ [ (:help-multi) ]
} cond (:help-debugger) ;
: remove-article ( name -- )
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib sequences.lib math ;
+macros combinators.lib sequences.lib math sets ;
IN: help.lint
: check-example ( element -- )
[ strong-style get print-element* ] ($heading) ;
: ($code-style) ( presentation -- hash )
- presented associate code-style get union ;
+ presented associate code-style get assoc-union ;
: ($code) ( presentation quot -- )
[
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics
namespaces vocabs definitions compiler.units ;
over add-article >link r> remember-definition ; parsing
: ABOUT:
- scan-object in get vocab set-vocab-help ; parsing
+ scan-object
+ in get vocab
+ dup changed-definition
+ set-vocab-help ; parsing
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;
-M: object >link link construct-boa ;
+M: object >link link boa ;
PREDICATE: word-link < link link-name word? ;
TUPLE: article title content loc ;
: <article> ( title content -- article )
- f \ article construct-boa ;
+ f \ article boa ;
M: article article-name article-title ;
TUPLE: no-article name ;
-: no-article ( name -- * ) \ no-article construct-boa throw ;
+: no-article ( name -- * ) \ no-article boa throw ;
M: no-article summary
drop "Help article does not exist" ;
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media"
+ "media" "title"
] [ define-attribute-word ] each
] with-compilation-unit
IN: html.tests
: make-html-string
- [ with-html-stream ] with-string-writer ;
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
[
- "<" "austin" funky construct-boa write-object
+ "<" "austin" funky boa write-object
] make-html-string
] unit-test
TUPLE: html-sub-stream style stream ;
: (html-sub-stream) ( style stream -- stream )
- html-sub-stream construct-boa
+ html-sub-stream boa
512 <sbuf> <html-stream> over set-delegate ;
: <html-sub-stream> ( style stream class -- stream )
! Utilities
: with-html-stream ( quot -- )
- stdio get <html-stream> swap with-stream* ;
+ stdio get <html-stream> swap with-stream* ; inline
: xhtml-preamble
"<?xml version=\"1.0\"?>" write-html
[ print-closing-named-tag ] }
{ [ dup tag-name string? ]
[ print-opening-named-tag ] }
- { [ t ] [ <unknown-tag-error> throw ] }
+ [ <unknown-tag-error> throw ]
} cond ;
SYMBOL: tablestack
USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences ;
+io.streams.string kernel arrays splitting sequences
+assocs io.sockets ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ ] [
[
<dispatcher>
- <action>
- [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
- "quit" add-responder
- "extra/http/test" resource-path <static> >>default
+ <action>
+ [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+ "quit" add-responder
+ <dispatcher>
+ "extra/http/test" resource-path <static> >>default
+ "nested" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
- "http://localhost:1237/foo.html" http-get =
+ "http://localhost:1237/nested/foo.html" http-get =
+] unit-test
+
+! Try with a slightly malformed request
+[ t ] [
+ "localhost" 1237 <inet> ascii <client> [
+ "GET nested HTTP/1.0\r\n" write flush
+ "\r\n" write flush
+ readln drop
+ read-header USE: prettyprint
+ ] with-stream dup . "location" swap at "/" head?
] unit-test
[ "Goodbye" ] [
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math
+USING: fry hashtables io io.streams.string kernel math sets
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting accessors calendar
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
TUPLE: cookie name value path domain expires http-only ;
: <cookie> ( value name -- cookie )
- cookie construct-empty
+ cookie new
swap >>name swap >>value ;
: parse-cookies ( string -- seq )
: (unparse-cookie) ( key value -- )
{
- { [ dup f eq? ] [ 2drop ] }
- { [ dup t eq? ] [ drop , ] }
- { [ t ] [ "=" swap 3append , ] }
- } cond ;
+ { f [ drop ] }
+ { t [ , ] }
+ [ "=" swap 3append , ]
+ } case ;
: unparse-cookie ( cookie -- strings )
[
cookies ;
: <request>
- request construct-empty
+ request new
"1.1" >>version
http-port >>port
H{ } clone >>header
body ;
: <response>
- response construct-empty
+ response new
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
[ unparse-cookies "set-cookie" pick set-at ] when*
write-header ;
+GENERIC: write-response-body* ( body -- )
+
+M: f write-response-body* drop ;
+
+M: string write-response-body* write ;
+
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
+
: write-response-body ( response -- response )
- dup body>> {
- { [ dup not ] [ drop ] }
- { [ dup string? ] [ write ] }
- { [ dup callable? ] [ call ] }
- { [ t ] [ stdio get stream-copy ] }
- } cond ;
+ dup body>> write-response-body* ;
M: response write-response ( respose -- )
write-response-version
body ;
: <raw-response> ( -- response )
- raw-response construct-empty
+ raw-response new
"1.1" >>version ;
M: raw-response write-response ( respose -- )
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
- action construct-empty\r
+ action new\r
[ ] >>init\r
[ <400> ] >>display\r
[ <400> ] >>submit ;\r
M: action call-responder ( path action -- response )\r
'[\r
, ,\r
- [ +append-path associate request-params union params set ]\r
+ [ +append-path associate request-params assoc-union params set ]\r
[ action set ] bi*\r
request get method>> {\r
{ "GET" [ handle-get ] }\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Edit profile</h1>\r
-\r
-<form method="POST" action="edit-profile">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-view %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Current password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you don't want to change your current password, leave this field blank.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>New password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you are changing your password, enter it twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Update" />\r
-\r
-<% {\r
- { [ login-failed? get ] [ "invalid password" render-error ] }\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form action="edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:view component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid password</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators http.server\r
-http.server.auth.providers http.server.auth.providers.null\r
-http.server.actions http.server.components http.server.sessions\r
-http.server.templating.fhtml http.server.validators\r
-http.server.auth http sequences io.files namespaces hashtables\r
+base64 io combinators sequences io.files namespaces hashtables\r
fry io.sockets arrays threads locals qualified continuations\r
-destructors ;\r
+destructors\r
+\r
+html.elements\r
+http\r
+http.server\r
+http.server.auth\r
+http.server.auth.providers\r
+http.server.auth.providers.null\r
+http.server.actions\r
+http.server.components\r
+http.server.forms\r
+http.server.sessions\r
+http.server.boilerplate\r
+http.server.templating\r
+http.server.templating.chloe\r
+http.server.validators ;\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
SYMBOL: post-login-url\r
SYMBOL: login-failed?\r
\r
-TUPLE: login users ;\r
+TUPLE: login < dispatcher users ;\r
\r
: users login get users>> ;\r
\r
: save-user-after ( user -- )\r
<user-saver> add-always-destructor ;\r
\r
+: login-template ( name -- template )\r
+ "resource:extra/http/server/auth/login/" swap ".xml"\r
+ 3append <chloe> ;\r
+\r
! ! ! Login\r
\r
: <login-form>\r
"login" <form>\r
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template\r
+ "login" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
: <register-form> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/register.fhtml" >>edit-template\r
+ "register" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
successful-login\r
\r
- login get responder>> init-user-profile\r
+ login get default>> responder>> init-user-profile\r
] >>submit\r
] ;\r
\r
\r
: <edit-profile-form> ( -- form )\r
"edit-profile" <form>\r
- "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template\r
+ "edit-profile" login-template >>edit-template\r
"username" <username> add-field\r
"realname" <string> add-field\r
"password" <password> add-field\r
dup email>> "email" set-value\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
"password" value uid users check-login\r
[ login-failed? on validation-failed ] unless\r
\r
- "new-password" value set-password\r
+ "new-password" value >>password\r
] unless\r
\r
"realname" value >>realname\r
\r
: <recover-form-1> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template\r
+ "recover-1" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
send-password-email\r
] when*\r
\r
- "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template\r
+ "recover-2" login-template serve-template\r
] >>submit\r
] ;\r
\r
: <recover-form-3>\r
"new-password" <form>\r
- "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template\r
- "username" <username> <hidden>\r
+ "recover-3" login-template >>edit-template\r
+ "username" <username>\r
+ hidden >>renderer\r
t >>required\r
add-field\r
"new-password" <password>\r
"verify-password" <password>\r
t >>required\r
add-field\r
- "ticket" <string> <hidden>\r
+ "ticket" <string>\r
+ hidden >>renderer\r
t >>required\r
add-field ;\r
\r
] H{ } make-assoc values set\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ <recover-form-3> edit-form ] >>body\r
- ] >>display\r
+ [ <recover-form-3> edit-form ] >>display\r
\r
[\r
blank-values\r
"new-password" value >>password\r
users update-user\r
\r
- "resource:extra/http/server/auth/login/recover-4.fhtml"\r
- serve-template\r
+ "recover-4" login-template serve-template\r
] [\r
<400>\r
] if*\r
"login" f <permanent-redirect> ;\r
\r
M: protected call-responder ( path responder -- response )\r
- logged-in-user sget [\r
- dup save-user-after\r
+ logged-in-user sget dup [\r
+ save-user-after\r
request get request-url previous-page sset\r
responder>> call-responder\r
] [\r
- 2drop\r
+ 3drop\r
request get method>> { "GET" "HEAD" } member?\r
[ show-login-page ] [ <400> ] if\r
] if ;\r
\r
M: login call-responder ( path responder -- response )\r
dup login set\r
- delegate call-responder ;\r
+ call-next-method ;\r
+\r
+: <login-boilerplate> ( responder -- responder' )\r
+ <boilerplate>\r
+ "boilerplate" login-template >>template ;\r
\r
: <login> ( responder -- auth )\r
- login <webapp>\r
+ login new-dispatcher\r
swap <protected> >>default\r
- <login-action> "login" add-responder\r
- <logout-action> "logout" add-responder\r
+ <login-action> <login-boilerplate> "login" add-responder\r
+ <logout-action> <login-boilerplate> "logout" add-responder\r
no-users >>users ;\r
\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected> "edit-profile" add-responder ;\r
+ <edit-profile-action> <protected> <login-boilerplate>\r
+ "edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
- <register-action> "register" add-responder ;\r
+ <register-action> <login-boilerplate>\r
+ "register" add-responder ;\r
\r
: allow-password-recovery ( login -- login )\r
- <recover-action-1> "recover-password" add-responder\r
- <recover-action-3> "new-password" add-responder ;\r
+ <recover-action-1> <login-boilerplate>\r
+ "recover-password" add-responder\r
+ <recover-action-3> <login-boilerplate>\r
+ "new-password" add-responder ;\r
\r
: allow-edit-profile? ( -- ? )\r
login get responders>> "edit-profile" swap key? ;\r
+++ /dev/null
-<% USING: http.server.auth.login http.server.components http.server\r
-kernel namespaces ; %>\r
-<html>\r
-<body>\r
-<h1>Login required</h1>\r
-\r
-<form method="POST" action="login">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Log in" />\r
-<%\r
-login-failed? get\r
-[ "Invalid username or password" render-error ] when\r
-%>\r
-</p>\r
-\r
-</form>\r
-\r
-<p>\r
-<% allow-registration? [ %>\r
- <a href="<% "register" f write-link %>">Register</a>\r
-<% ] when %>\r
-<% allow-password-recovery? [ %>\r
- <a href="<% "recover-password" f write-link %>">\r
- Recover Password\r
- </a>\r
-<% ] when %>\r
-</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Login</t:title>
+
+ <t:form action="login">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Log in" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid username or password</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+ <p>
+ <t:if code="http.server.auth.login:login-failed?">
+ <t:a href="register">Register</t:a>
+ </t:if>
+ |
+ <t:if code="http.server.auth.login:allow-password-recovery?">
+ <t:a href="recover-password">Recover Password</t:a>
+ </t:if>
+ </p>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 1 of 4</h1>\r
-\r
-<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>\r
-\r
-<form method="POST" action="recover-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<input type="submit" value="Recover password" />\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+ <t:form action="recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 2 of 4</h1>\r
-\r
-<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login http.server\r
-namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 3 of 4</h1>\r
-\r
-<p>Choose a new password for your account.</p>\r
-\r
-<form method="POST" action="new-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<% "username" component render-edit %>\r
-<% "ticket" component render-edit %>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify password:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Set password" />\r
-\r
-<% password-mismatch? get [\r
- "passwords do not match" render-error\r
-] when %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form action="new-password">
+
+ <table>
+
+ <t:edit component="username" />
+ <t:edit component="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 4 of 4</h1>\r
-\r
-<p>Your password has been reset.\r
-You may now <a href="<% "login" f write-link %>">log in</a>.</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>\r
+\r
+</t:chloe>\r
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>New user registration</h1>\r
-\r
-<form method="POST" action="register">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Register" />\r
-\r
-<% {\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ user-exists? get ] [ "username taken" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+
+ <t:if var="http.server.auth.login:user-exists?">
+ <t:error>username taken</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
-[ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+[ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
TUPLE: users-in-memory assoc ;\r
\r
: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory construct-boa ;\r
+ H{ } clone users-in-memory boa ;\r
\r
M: users-in-memory get-user ( username provider -- user/f )\r
assoc>> at ;\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
- [ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+ [ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ ] [ "user" get "provider" get update-user ] unit-test\r
\r
\r
TUPLE: user username realname password email ticket profile ;\r
\r
-: <user> user construct-empty H{ } clone >>profile ;\r
+: <user> user new H{ } clone >>profile ;\r
\r
GENERIC: get-user ( username provider -- user/f )\r
\r
: check-login ( password username provider -- user/f )\r
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
\r
-: set-password ( user password -- user ) >>password ;\r
-\r
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces boxes sequences strings
+io io.streams.string
+http
+http.server
+http.server.templating ;
+IN: http.server.boilerplate
+
+TUPLE: boilerplate responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+ title get >box ;
+
+: write-title ( -- )
+ title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+ "\n" style get push-all
+ style get push-all ;
+
+: write-style ( -- )
+ style get >string write ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write ;
+
+M: f call-template drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ write-response-body*
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+M: boilerplate call-responder
+ [ responder>> call-responder clone ] [ template>> ] bi
+ [ [ with-boilerplate ] 2curry ] curry change-body ;
#! A continuation responder is a special type of session\r
#! manager. However it works entirely differently from\r
#! the URL and cookie session managers.\r
- H{ } clone callback-responder construct-boa ;\r
+ H{ } clone callback-responder boa ;\r
\r
TUPLE: callback cont quot expires alarm responder ;\r
\r
] when drop ;\r
\r
: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback construct-boa\r
+ f callback-responder get callback boa\r
dup touch-callback ;\r
\r
: invoke-callback ( callback -- response )\r
IN: http.server.components.tests\r
-USING: http.server.components http.server.validators\r
-namespaces tools.test kernel accessors\r
-tuple-syntax mirrors http.server.actions ;\r
+USING: http.server.components http.server.forms\r
+http.server.validators namespaces tools.test kernel accessors\r
+tuple-syntax mirrors\r
+http http.server.actions http.server.templating.fhtml\r
+io.streams.string io.streams.null ;\r
\r
validation-failed? off\r
\r
\r
TUPLE: test-tuple text number more-text ;\r
\r
-: <test-tuple> test-tuple construct-empty ;\r
+: <test-tuple> test-tuple new ;\r
\r
: <test-form> ( -- form )\r
"test" <form>\r
- "resource:extra/http/server/components/test/form.fhtml" >>view-template\r
- "resource:extra/http/server/components/test/form.fhtml" >>edit-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template\r
"text" <string>\r
t >>required\r
add-field\r
"hi" >>default\r
add-field ;\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test\r
\r
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
<test-tuple> from-tuple\r
"123" "n" get validate value>>\r
] unit-test\r
\r
- [ ] [ "n" get t >>integer drop ] unit-test\r
+ [ ] [ "i" <integer> "i" set ] unit-test\r
\r
[ 3 ] [\r
- "3" "n" get validate\r
+ "3" "i" get validate\r
] unit-test\r
+ \r
+ [ t ] [\r
+ "3.9" "i" get validate validation-error?\r
+ ] unit-test\r
+\r
+ H{ } clone values set\r
+\r
+ [ ] [ 3 "i" set-value ] unit-test\r
+\r
+ [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test\r
+\r
+ [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test\r
+\r
+ [ ] [ "t" <text> "t" set ] unit-test\r
+\r
+ [ ] [ "hello world" "t" set-value ] unit-test\r
+\r
+ [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test\r
] with-scope\r
\r
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
+\r
+[ ] [ "password" <password> "p" set ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements http.server.validators accessors namespaces
kernel io math.parser assocs classes words classes.tuple arrays
-sequences io.files http.server.templating.fhtml
-http.server.actions splitting mirrors hashtables fry
+sequences splitting mirrors hashtables fry combinators
continuations math ;
IN: http.server.components
+! Renderer protocol
+GENERIC: render-summary* ( value renderer -- )
+GENERIC: render-view* ( value renderer -- )
+GENERIC: render-edit* ( value id renderer -- )
+
+M: object render-summary* render-view* ;
+
+TUPLE: field type ;
+
+C: <field> field
+
+M: field render-view* drop write ;
+
+M: field render-edit*
+ <input type>> =type [ =id ] [ =name ] bi =value input/> ;
+
+: render-error ( message -- )
+ <span "error" =class span> write </span> ;
+
+TUPLE: hidden < field ;
+
+: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+
+M: hidden render-view* 2drop ;
+
+! Component protocol
SYMBOL: components
-TUPLE: component id required default ;
+TUPLE: component id required default renderer ;
: component ( name -- component )
dup components get at
[ ] [ "No such component: " prepend throw ] ?if ;
+GENERIC: init ( component -- component )
+
+M: component init ;
+
GENERIC: validate* ( value component -- result )
-GENERIC: render-view* ( value component -- )
-GENERIC: render-edit* ( value component -- )
-GENERIC: render-error* ( reason value component -- )
+GENERIC: component-string ( value component -- string )
SYMBOL: values
: set-value values get set-at ;
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
+: blank-values H{ } clone values set ;
-: render-view ( component -- )
- [ id>> value ] [ render-view* ] bi ;
+: from-tuple <mirror> values set ;
-: render-error ( error -- )
- <span "error" =class span> write </span> ;
+: values-tuple values get mirror-object ;
-: render-edit ( component -- )
- dup id>> value dup validation-error? [
- [ reason>> ] [ value>> ] bi rot render-error*
- ] [
- swap [ default>> or ] keep render-edit*
- ] if ;
-
-: <component> ( id class -- component )
- \ component construct-empty
- swap construct-delegate
- swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
- form <component>
- V{ } clone >>components ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
- >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: view-form ( form -- )
- dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
+: render-view ( component -- )
+ [ id>> value ] [ component-string ] [ renderer>> ] tri
+ render-view* ;
-: blank-values H{ } clone values set ;
+<PRIVATE
-: from-tuple <mirror> values set ;
+: render-edit-string ( string component -- )
+ [ id>> ] [ renderer>> ] bi render-edit* ;
-: values-tuple values get mirror-object ;
+: render-edit-error ( component -- )
+ [ id>> value ] keep
+ [ [ value>> ] dip render-edit-string ]
+ [ drop reason>> render-error ] 2bi ;
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
+: value-or-default ( component -- value )
+ [ id>> value ] [ default>> ] bi or ;
-: render-input ( value component type -- )
- <input
- =type
- id>> [ =id ] [ =name ] bi
- =value
- input/> ;
+: render-edit-value ( component -- )
+ [ value-or-default ]
+ [ component-string ]
+ [ render-edit-string ]
+ tri ;
-! Hidden fields
-TUPLE: hidden ;
+PRIVATE>
-: <hidden> ( component -- component )
- hidden construct-delegate ;
+: render-edit ( component -- )
+ dup id>> value validation-error?
+ [ render-edit-error ] [ render-edit-value ] if ;
-M: hidden render-view*
- 2drop ;
+: validate ( value component -- result )
+ '[
+ ,
+ over empty? [
+ [ default>> [ v-default ] when* ]
+ [ required>> [ v-required ] when ]
+ bi
+ ] [ validate* ] if
+ ] with-validator ;
-M: hidden render-edit*
- >r dup number? [ number>string ] when r>
- "hidden" render-input ;
+: new-component ( id class renderer -- component )
+ swap new
+ swap >>renderer
+ swap >>id
+ init ; inline
! String input fields
-TUPLE: string min-length max-length ;
+TUPLE: string < component one-line min-length max-length ;
-: <string> ( id -- component ) string <component> ;
-
-M: string validate*
- [ v-one-line ] [
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- bi
- ] bi* ;
+: new-string ( id class -- component )
+ "text" <field> new-component
+ t >>one-line ; inline
-M: string render-view*
- drop write ;
+: <string> ( id -- component )
+ string new-string ;
-M: string render-edit*
- "text" render-input ;
+M: string validate*
+ [ one-line>> [ v-one-line ] when ]
+ [ min-length>> [ v-min-length ] when* ]
+ [ max-length>> [ v-max-length ] when* ]
+ tri ;
-M: string render-error*
- "text" render-input render-error ;
+M: string component-string
+ drop ;
! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
+
+M: username init
+ 2 >>min-length
+ 20 >>max-length ;
: <username> ( id -- component )
- <string> username construct-delegate
- 2 >>min-length
- 20 >>max-length ;
+ username new-string ;
M: username validate*
- delegate validate* v-one-word ;
+ call-next-method v-one-word ;
! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
: <email> ( id -- component )
- <string> email construct-delegate
+ email new-string
5 >>min-length
60 >>max-length ;
M: email validate*
- delegate validate* dup empty? [ v-email ] unless ;
+ call-next-method dup empty? [ v-email ] unless ;
+
+! Don't send passwords back to the user
+TUPLE: password-renderer < field ;
+
+: password-renderer T{ password-renderer f "password" } ;
+
+: blank-password >r >r drop "" r> r> ;
+
+M: password-renderer render-edit*
+ blank-password call-next-method ;
! Password fields
-TUPLE: password ;
+TUPLE: password < string ;
+
+M: password init
+ 6 >>min-length
+ 60 >>max-length ;
: <password> ( id -- component )
- <string> password construct-delegate
- 6 >>min-length
- 60 >>max-length ;
+ password new-string
+ password-renderer >>renderer ;
M: password validate*
- delegate validate* v-one-word ;
-
-M: password render-edit*
- >r drop f r> "password" render-input ;
-
-M: password render-error*
- render-edit* render-error ;
+ call-next-method v-one-word ;
! Number fields
-TUPLE: number min-value max-value integer ;
+TUPLE: number < string min-value max-value ;
-: <number> ( id -- component ) number <component> ;
+: <number> ( id -- component )
+ number new-string ;
M: number validate*
[ v-number ] [
- [ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
- tri
+ bi
] bi* ;
-M: number render-view*
- drop number>string write ;
+M: number component-string
+ drop dup [ number>string ] when ;
+
+! Integer fields
+TUPLE: integer < number ;
-M: number render-edit*
- >r number>string r> "text" render-input ;
+: <integer> ( id -- component )
+ integer new-string ;
-M: number render-error*
- "text" render-input render-error ;
+M: integer validate*
+ call-next-method v-integer ;
+
+! Simple captchas
+TUPLE: captcha < string ;
+
+: <captcha> ( id -- component )
+ captcha new-string ;
+
+M: captcha validate*
+ drop v-captcha ;
! Text areas
-TUPLE: text ;
+TUPLE: textarea-renderer rows cols ;
-: <text> ( id -- component ) text <component> ;
+: new-textarea-renderer ( class -- renderer )
+ new
+ 60 >>cols
+ 20 >>rows ;
-M: text validate* drop ;
+: <textarea-renderer> ( -- renderer )
+ textarea-renderer new-textarea-renderer ;
-M: text render-view*
+M: textarea-renderer render-view*
drop write ;
-: render-textarea
+M: textarea-renderer render-edit*
<textarea
- id>> [ =id ] [ =name ] bi
+ [ rows>> [ number>string =rows ] when* ]
+ [ cols>> [ number>string =cols ] when* ] bi
+ [ =id ]
+ [ =name ] bi
textarea>
write
</textarea> ;
-M: text render-edit*
- render-textarea ;
+TUPLE: text < string ;
-M: text render-error*
- render-textarea render-error ;
+: new-text ( id class -- component )
+ new-string
+ f >>one-line
+ <textarea-renderer> >>renderer ;
-! Simple captchas
-TUPLE: captcha ;
+: <text> ( id -- component )
+ text new-text ;
-: <captcha> ( id -- component )
- <string> captcha construct-delegate ;
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
-M: captcha validate*
- drop v-captcha ;
+TUPLE: list-renderer component type ;
+
+C: <list-renderer> list-renderer
+
+: render-list ( value component -- )
+ [ render-summary* ] curry each ;
+
+: render-ordered-list ( value component -- )
+ [ <li> render-summary* </li> ] curry each ;
+
+: render-unordered-list ( value component -- )
+ [ <li> render-summary* </li> ] curry each ;
+
+M: list-renderer render-view*
+ [ component>> ] [ type>> ] bi {
+ { +plain+ [ render-list ] }
+ { +ordered+ [ <ol> render-ordered-list </ol> ] }
+ { +unordered+ [ <ul> render-unordered-list </ul> ] }
+ } case ;
+
+TUPLE: list < component ;
+
+: <list> ( id component type -- list )
+ <list-renderer> list swap new-component ;
+
+M: list component-string drop ;
! Copyright (C) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: splitting http.server.components kernel io sequences\r
-farkup ;\r
+USING: splitting kernel io sequences farkup accessors\r
+http.server.components ;\r
IN: http.server.components.farkup\r
\r
-TUPLE: farkup ;\r
+TUPLE: farkup-renderer < textarea-renderer ;\r
\r
-: <farkup> ( id -- component )\r
- <text> farkup construct-delegate ;\r
+: <farkup-renderer>\r
+ farkup-renderer new-textarea-renderer ;\r
\r
-M: farkup render-view*\r
+M: farkup-renderer render-view*\r
drop string-lines "\n" join convert-farkup write ;\r
+\r
+: <farkup> ( id -- component )\r
+ <text>\r
+ <farkup-renderer> >>renderer ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces db.tuples math.parser
+accessors fry locals hashtables
+http.server
+http.server.actions
+http.server.components
+http.server.forms
+http.server.validators ;
IN: http.server.crud
-USING: kernel namespaces db.tuples math.parser http.server
-http.server.actions http.server.components
-http.server.validators accessors fry locals hashtables ;
:: <view-action> ( form ctor -- action )
<action>
[ "id" get ctor call select-tuple from-tuple ] >>init
- [
- "text/html" <content>
- [ form view-form ] >>body
- ] >>display ;
+ [ form view-form ] >>display ;
: <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ;
-:: <create-action> ( form ctor next -- action )
+:: <edit-action> ( form ctor next -- action )
<action>
- [ f ctor call from-tuple form set-defaults ] >>init
+ { { "id" [ [ v-number ] v-optional ] } } >>get-params
[
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
-
- [
- f ctor call from-tuple
+ "id" get ctor call
- form validate-form
-
- values-tuple insert-tuple
+ "id" get
+ [ select-tuple from-tuple ]
+ [ from-tuple form set-defaults ]
+ if
+ ] >>init
- "id" value next <id-redirect>
- ] >>submit ;
-
-:: <edit-action> ( form ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
- [ "id" get ctor call select-tuple from-tuple ] >>init
-
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
f ctor call from-tuple
form validate-form
- values-tuple update-tuple
+ values-tuple
+ "id" value [ update-tuple ] [ insert-tuple ] if
"id" value next <id-redirect>
] >>submit ;
next f <permanent-redirect>
] >>submit ;
+
+:: <list-action> ( form ctor -- action )
+ <action>
+ [
+ blank-values
+
+ f ctor call select-tuples "list" set-value
+
+ form view-form
+ ] >>display ;
C: <db-persistence> db-persistence\r
\r
: connect-db ( db-persistence -- )\r
- [ db>> ] [ params>> ] bi make-db\r
- [ db set ] [ db-open ] [ add-always-destructor ] tri ;\r
+ [ db>> ] [ params>> ] bi make-db db-open\r
+ [ db set ] [ add-always-destructor ] bi ;\r
\r
M: db-persistence call-responder\r
[ connect-db ] [ responder>> call-responder ] bi ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
+http.server.actions
+http.server.components
+http.server.validators
+http.server.templating ;
+IN: http.server.forms
+
+TUPLE: form < component
+view-template edit-template summary-template
+components ;
+
+M: form init V{ } clone >>components ;
+
+: <form> ( id -- form )
+ form f new-component ;
+
+: add-field ( form component -- form )
+ dup id>> pick components>> set-at ;
+
+: set-components ( form -- )
+ components>> components set ;
+
+: with-form ( form quot -- )
+ [ [ set-components ] [ call ] bi* ] with-scope ; inline
+
+: set-defaults ( form -- )
+ [
+ components get [
+ swap values get [
+ swap default>> or
+ ] change-at
+ ] assoc-each
+ ] with-form ;
+
+: <form-response> ( form template -- response )
+ [ components>> components set ]
+ [ "text/html" <content> swap >>body ]
+ bi* ;
+
+: view-form ( form -- response )
+ dup view-template>> <form-response> ;
+
+: edit-form ( form -- response )
+ dup edit-template>> <form-response> ;
+
+: validate-param ( id component -- )
+ [ [ params get at ] [ validate ] bi* ]
+ [ drop set-value ] 2bi ;
+
+: (validate-form) ( form -- error? )
+ [
+ validation-failed? off
+ components get [ validate-param ] assoc-each
+ validation-failed? get
+ ] with-form ;
+
+: validate-form ( form -- )
+ (validate-form) [ validation-failed ] when ;
+
+: render-form ( value form template -- )
+ [
+ [ from-tuple ]
+ [ set-components ]
+ [ call-template ]
+ tri*
+ ] with-scope ;
+
+M: form render-summary*
+ dup summary-template>> render-form ;
+
+M: form render-view*
+ dup view-template>> render-form ;
+
+M: form render-edit*
+ dup edit-template>> render-form ;
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ t ] [ relative-redirect ] }
+ [ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
TUPLE: dispatcher default responders ;
+: new-dispatcher ( class -- dispatcher )
+ new
+ 404-responder get >>default
+ H{ } clone >>responders ; inline
+
: <dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone dispatcher construct-boa ;
+ dispatcher new-dispatcher ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
2drop redirect-with-/
] if ;
-: <webapp> ( class -- dispatcher )
- <dispatcher> swap construct-delegate ; inline
-
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+ 404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
TUPLE: session-manager responder sessions ;
-: <session-manager> ( responder class -- responder' )
- >r <sessions-in-memory> session-manager construct-boa
- r> construct-delegate ; inline
+: new-session-manager ( responder class -- responder' )
+ new
+ <sessions-in-memory> >>sessions
+ swap >>responder ; inline
SYMBOLS: session session-id session-changed? ;
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
-TUPLE: null-sessions ;
+TUPLE: null-sessions < session-manager ;
: <null-sessions>
- null-sessions <session-manager> ;
+ null-sessions new-session-manager ;
M: null-sessions call-responder ( path responder -- response )
H{ } clone f call-responder/session ;
-TUPLE: url-sessions ;
+TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' )
- url-sessions <session-manager> ;
+ url-sessions new-session-manager ;
: session-id-key "factorsessid" ;
[ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
- session-id get [ session-id-key associate union ] when* ;
+ session-id get [ session-id-key associate assoc-union ] when* ;
: session-form-field ( -- )
<input
2drop nip new-url-session
] if ;
-TUPLE: cookie-sessions ;
+TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' )
- cookie-sessions <session-manager> ;
+ cookie-sessions new-session-manager ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup
TUPLE: sessions-in-memory sessions alarms ;\r
\r
: <sessions-in-memory> ( -- storage )\r
- H{ } clone H{ } clone sessions-in-memory construct-boa ;\r
+ H{ } clone H{ } clone sessions-in-memory boa ;\r
\r
: cancel-session-timeout ( id storage -- )\r
alarms>> at [ cancel-alarm ] when* ;\r
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
- session construct-empty
+ session new
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- namespace/f )
TUPLE: file-responder root hook special ;\r
\r
: file-http-date ( filename -- string )\r
- file-info file-info-modified timestamp>http-string ;\r
+ file-info modified>> timestamp>http-string ;\r
\r
: last-modified-matches? ( filename -- ? )\r
file-http-date dup [\r
304 "Not modified" <trivial-response> ;\r
\r
: <file-responder> ( root hook -- responder )\r
- H{ } clone file-responder construct-boa ;\r
+ H{ } clone file-responder boa ;\r
\r
: <static> ( root -- responder )\r
[\r
<content>\r
swap\r
- [ file-info file-info-size "content-length" set-header ]\r
+ [ file-info size>> "content-length" set-header ]\r
[ file-http-date "last-modified" set-header ]\r
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
tri\r
--- /dev/null
+USING: http.server.templating http.server.templating.chloe
+http.server.components http.server.boilerplate tools.test
+io.streams.string kernel sequences ascii boxes namespaces xml
+splitting ;
+IN: http.server.templating.chloe.tests
+
+[ "foo" ]
+[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
+unit-test
+
+[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
+[ "href attribute is required" = ]
+must-fail-with
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ blank-values
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ blank-values
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
+
+: run-template
+ with-string-writer [ "\r\n\t" member? not ] subset
+ "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+ "resource:extra/http/server/templating/chloe/test/"
+ swap
+ ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+ [
+ "test1" test-template call-template
+ ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+ [
+ <box> title set
+ [
+ "test2" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+ [
+ [
+ "test2" test-template call-template
+ ] "test3" test-template with-boilerplate
+ ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+ [
+ "test4" test-template call-template
+ ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+ [
+ "test5" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test6-aux?
+
+[ "True" ] [
+ [
+ test6-aux? on
+ "test6" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test7-aux?
+
+[ "" ] [
+ [
+ test7-aux? off
+ "test7" test-template call-template
+ ] run-template
+] unit-test
--- /dev/null
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays
+io.files io.encodings.utf8 html.elements unicode.case
+tuple-syntax xml xml.data xml.writer xml.utilities
+http.server
+http.server.auth
+http.server.components
+http.server.sessions
+http.server.templating
+http.server.boilerplate ;
+IN: http.server.templating.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
+
+: chloe-tag? ( tag -- ? )
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup chloe-ns names-match? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+SYMBOL: tags
+
+: required-attr ( tag name -- value )
+ dup rot at*
+ [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+ swap at ;
+
+: write-title-tag ( tag -- )
+ drop
+ "head" tags get member? "title" tags get member? not and
+ [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+ dup "include" optional-attr dup [
+ swap children>string empty? [
+ "style tag cannot have both an include attribute and a body" throw
+ ] unless
+ utf8 file-contents
+ ] [
+ drop children>string
+ ] if add-style ;
+
+: write-style-tag ( tag -- )
+ drop <style> write-style </style> ;
+
+: component-attr ( tag -- name )
+ "component" required-attr ;
+
+: view-tag ( tag -- )
+ component-attr component render-view ;
+
+: edit-tag ( tag -- )
+ component-attr component render-edit ;
+
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: a-start-tag ( tag -- )
+ <a
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ]
+ bi link>string =href
+ a> ;
+
+: process-tag-children ( tag -- )
+ [ process-template ] each ;
+
+: a-tag ( tag -- )
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop </a> ]
+ tri ;
+
+: form-start-tag ( tag -- )
+ <form
+ "POST" =method
+ tag-attrs print-attrs
+ form>
+ hidden-form-field ;
+
+: form-tag ( tag -- )
+ [ form-start-tag ]
+ [ process-tag-children ]
+ [ drop </form> ]
+ tri ;
+
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+ attr>word dup symbol? [
+ "Must be a symbol: " swap append throw
+ ] unless ;
+
+: if-satisfied? ( tag -- ? )
+ {
+ [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+ [ "var" optional-attr [ attr>var get ] [ t ] if* ]
+ [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
+ [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
+ } cleave 4array [ ] all? ;
+
+: if-tag ( tag -- )
+ dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
+: error-tag ( tag -- )
+ children>string render-error ;
+
+: process-chloe-tag ( tag -- )
+ dup name-tag {
+ { "chloe" [ [ process-template ] each ] }
+ { "title" [ children>string set-title ] }
+ { "write-title" [ write-title-tag ] }
+ { "style" [ style-tag ] }
+ { "write-style" [ write-style-tag ] }
+ { "view" [ view-tag ] }
+ { "edit" [ edit-tag ] }
+ { "a" [ a-tag ] }
+ { "form" [ form-tag ] }
+ { "error" [ error-tag ] }
+ { "if" [ if-tag ] }
+ { "call-next-template" [ drop call-next-template ] }
+ [ "Unknown chloe tag: " swap append throw ]
+ } case ;
+
+: process-tag ( tag -- )
+ {
+ [ name-tag >lower tags get push ]
+ [ write-start-tag ]
+ [ process-tag-children ]
+ [ write-end-tag ]
+ [ drop tags get pop* ]
+ } cleave ;
+
+: process-template ( xml -- )
+ {
+ { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ t ] [ write-item ] }
+ } cond ;
+
+: process-chloe ( xml -- )
+ [
+ V{ } clone tags set
+
+ nested-template? get [
+ process-template
+ ] [
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ process-template ]
+ [ xml-after write-chunk ]
+ } cleave
+ ] if
+ ] with-scope ;
+
+M: chloe call-template
+ path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <html>
+ <head>
+ <t:write-title />
+ </head>
+ <body>
+ <t:call-next-template />
+ </body>
+ </html>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test4-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test5-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test6-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test7-aux?">
+ True
+ </t:if>
+
+</t:chloe>
USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating.fhtml kernel tools.test sequences
-parser ;
+http.server.templating http.server.templating.fhtml kernel
+tools.test sequences parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/"
prepend
[
- ".fhtml" append [ run-template ] with-string-writer
+ ".fhtml" append <fhtml> [ call-template ] with-string-writer
] keep
".html" append utf8 file-contents = ;
! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
-io.files io.streams.string html html.elements source-files
-debugger combinators math quotations generic strings splitting
-accessors http.server.static http.server assocs
-io.encodings.utf8 fry ;
-
+USING: continuations sequences kernel namespaces debugger
+combinators math quotations generic strings splitting
+accessors assocs fry
+parser io io.files io.streams.string io.encodings.utf8 source-files
+html html.elements
+http.server.static http.server http.server.templating ;
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
-TUPLE: template-lexer ;
+TUPLE: template-lexer < lexer ;
: <template-lexer> ( lines -- lexer )
- <lexer> template-lexer construct-delegate ;
+ template-lexer new-lexer ;
M: template-lexer skip-word
[
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- { [ t ] [ f skip ] }
+ [ f skip ]
} cond
] change-lexer-column ;
DEFER: <% delimiter
: check-<% ( lexer -- col )
- "<%" over lexer-line-text rot lexer-column start* ;
+ "<%" over line-text>> rot column>> start* ;
: found-<% ( accum lexer col -- accum )
[
- over lexer-line-text
- >r >r lexer-column r> r> subseq parsed
+ over line-text>>
+ >r >r column>> r> r> subseq parsed
\ write-html parsed
- ] 2keep 2 + swap set-lexer-column ;
+ ] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
- dup lexer-line-text swap lexer-column tail
+ [ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
] keep next-line ;
: html-error. ( error -- )
<pre> error. </pre> ;
-: run-template ( filename -- )
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template ( filename -- )
'[
- , [
+ , path>> [
"quiet" on
parser-notes off
templating-vocab use+
] with-file-vocabs
] assert-depth ;
-: template-convert ( infile outfile -- )
- utf8 [ run-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( name -- response )
- "text/html" <content>
- swap '[ , run-template ] >>body ;
-
! file responder integration
: enable-fhtml ( responder -- responder )
- [ serve-template ]
+ [ <fhtml> serve-template ]
"application/x-factor-server-page"
pick special>> set-at ;
+
+INSTANCE: fhtml template
--- /dev/null
+USING: accessors kernel fry io.encodings.utf8 io.files
+http http.server ;
+IN: http.server.templating
+
+MIXIN: template
+
+GENERIC: call-template ( template -- )
+
+M: template write-response-body* call-template ;
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
+
+! responder integration
+: serve-template ( template -- response )
+ "text/html" <content>
+ swap '[ , call-template ] >>body ;
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces
+USING: kernel continuations sequences math namespaces sets
math.parser assocs regexp fry unicode.categories sequences ;
IN: http.server.validators
C: <validation-error> validation-error
: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ;
- inline
+ [ validation-failed? on <validation-error> ] recover ; inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
+: v-optional ( str quot -- str )
+ over empty? [ 2drop f ] [ call ] if ; inline
+
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
-: empty-cons ( -- cons ) cons construct-empty ;
+: empty-cons ( -- cons ) cons new ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
IN: inverse
TUPLE: fail ;
-: fail ( -- * ) \ fail construct-empty throw ;
+: fail ( -- * ) \ fail new throw ;
M: fail summary drop "Unification failed" ;
: assure ( ? -- ) [ fail ] unless ;
"pop-inverse" set-word-prop ;
TUPLE: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
+: no-inverse ( word -- * ) \ no-inverse new throw ;
M: no-inverse summary
drop "The word cannot be used in pattern matching" ;
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
+\ prefix [ unclip ] define-inverse
+\ unclip [ prefix ] define-inverse
+\ suffix [ dup 1 head* swap peek ] define-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
: boa-inverse ( class -- quot )
[ deconstruct-pred ] keep slot-readers compose ;
-\ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
+\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
[ tuple>array 1 tail [ ] contains? [ fail ] when ]
compose ;
-\ construct-empty 1 [ ?wrapped empty-inverse ] define-pop-inverse
+\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: writer>reader ( word -- word' )
[ "writing" word-prop "slots" word-prop ] keep
MACRO: matches? ( quot -- ? ) [matches?] ;
TUPLE: no-match ;
-: no-match ( -- * ) \ no-match construct-empty throw ;
+: no-match ( -- * ) \ no-match new throw ;
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
TUPLE: buffer size ptr fill pos ;
: <buffer> ( n -- buffer )
- dup malloc 0 0 buffer construct-boa ;
+ dup malloc 0 0 buffer boa ;
: buffer-free ( buffer -- )
dup buffer-ptr free f swap set-buffer-ptr ;
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup io.encodings.8-bit.private ;
+USING: help.syntax help.markup io.encodings.8-bit.private
+strings ;
IN: io.encodings.8-bit
ARTICLE: "io.encodings.8-bit" "8-bit encodings"
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
HELP: define-8-bit-encoding
-{ $values { "name" "a string" } { "path" "a path" } }
-{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
+{ $values { "name" string } { "stream" "an input stream" } }
+{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
HELP: latin1
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit construct-boa ] 2curry dupd curry define ;
+ [ 8-bit boa ] 2curry dupd curry define ;
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
C: strict strict
TUPLE: decode-error ;
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+: decode-error ( -- * ) \ decode-error new throw ;
M: decode-error summary
drop "Error in decoding input stream" ;
{ $values { "process" process } }
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
-HELP: process-stream
-{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
-
HELP: <process-stream>
{ $values
{ "desc" "a launch descriptor" }
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "status" "an exit code" } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
-io.nonblocking accessors ;
+io.nonblocking accessors concurrency.flags ;
IN: io.launcher
TUPLE: process < identity-tuple
SYMBOL: +realtime-priority+
: <process> ( -- process )
- process construct-empty
+ process new
H{ } clone >>environment
+append-environment+ >>environment-mode ;
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-HOOK: register-process io-backend ( process -- )
+HOOK: wait-for-processes io-backend ( -- ? )
-M: object register-process drop ;
+SYMBOL: wait-flag
+
+: wait-loop ( -- )
+ processes get assoc-empty?
+ [ wait-flag get-global lower-flag ]
+ [ wait-for-processes [ 100 sleep ] when ] if ;
+
+: start-wait-thread ( -- )
+ <flag> wait-flag set-global
+ [ wait-loop t ] "Process wait" spawn-server drop ;
+
+[ start-wait-thread ] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle
- V{ } clone over processes get set-at
- register-process ;
+ V{ } clone swap processes get set-at
+ wait-flag get-global raise-flag ;
M: process hashcode* process-handle hashcode* ;
: get-environment ( process -- env )
dup environment>>
swap environment-mode>> {
- { +prepend-environment+ [ os-envs union ] }
- { +append-environment+ [ os-envs swap union ] }
+ { +prepend-environment+ [ os-envs assoc-union ] }
+ { +append-environment+ [ os-envs swap assoc-union ] }
{ +replace-environment+ [ ] }
} case ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
- \ process-failed construct-boa throw ;
+ \ process-failed boa throw ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
HOOK: (process-stream) io-backend ( process -- handle in out )
-TUPLE: process-stream process ;
+: <process-stream*> ( desc encoding -- stream process )
+ >r >process dup dup (process-stream) <reader&writer>
+ r> <encoder-duplex> -roll
+ process-started ;
: <process-stream> ( desc encoding -- stream )
- >r >process dup dup (process-stream)
- >r >r process-started process-stream construct-boa
- r> r> <reader&writer> r> <encoder-duplex>
- over set-delegate ;
+ <process-stream*> drop ; inline
: with-process-stream ( desc quot -- status )
- swap <process-stream>
+ swap <process-stream*> >r
[ swap with-stream ] keep
- process>> wait-for-process ; inline
+ r> wait-for-process ; inline
: notify-exit ( process status -- )
>>status
USING: io io.mmap io.files kernel tools.test continuations
-sequences io.encodings.ascii ;
+sequences io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
IN: io.monitors\r
-USING: help.markup help.syntax continuations ;\r
+USING: help.markup help.syntax continuations\r
+concurrency.mailboxes quotations ;\r
+\r
+HELP: with-monitors\r
+{ $values { "quot" quotation } }\r
+{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }\r
+{ $errors "Throws an error if the platform does not support file system change monitors." } ;\r
\r
HELP: <monitor>\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }\r
-{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."\r
-$nl\r
-"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
+\r
+HELP: (monitor)\r
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: next-change\r
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }\r
-{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;\r
+{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }\r
+{ $errors "Throws an error if the monitor is closed from another thread." } ;\r
\r
HELP: with-monitor\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }\r
-{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;\r
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: +add-file+\r
-{ $description "Indicates that the file has been added to the directory." } ;\r
+{ $description "Indicates that a file has been added to its parent directory." } ;\r
\r
HELP: +remove-file+\r
-{ $description "Indicates that the file has been removed from the directory." } ;\r
+{ $description "Indicates that a file has been removed from its parent directory." } ;\r
\r
HELP: +modify-file+\r
-{ $description "Indicates that the file contents have changed." } ;\r
+{ $description "Indicates that a file's contents have changed." } ;\r
+\r
+HELP: +rename-file-old+\r
+{ $description "Indicates that a file has been renamed, and this is the old name." } ;\r
+\r
+HELP: +rename-file-new+\r
+{ $description "Indicates that a file has been renamed, and this is the new name." } ;\r
\r
HELP: +rename-file+\r
-{ $description "Indicates that file has been renamed." } ;\r
+{ $description "Indicates that a file has been renamed." } ;\r
\r
ARTICLE: "io.monitors.descriptors" "File system change descriptors"\r
"Change descriptors output by " { $link next-change } ":"\r
{ $subsection +add-file+ }\r
{ $subsection +remove-file+ }\r
{ $subsection +modify-file+ }\r
-{ $subsection +rename-file+ }\r
-{ $subsection +add-file+ } ;\r
+{ $subsection +rename-file-old+ }\r
+{ $subsection +rename-file-new+ }\r
+{ $subsection +rename-file+ } ;\r
+\r
+ARTICLE: "io.monitors.platforms" "Monitors on different platforms"\r
+"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."\r
+{ $heading "Mac OS X" }\r
+"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."\r
+$nl\r
+{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."\r
+$nl\r
+"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."\r
+{ $heading "Windows" }\r
+"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."\r
+$nl\r
+"Both recursive and non-recursive monitors are directly supported by the operating system."\r
+{ $heading "Linux" }\r
+"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."\r
+$nl\r
+"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."\r
+$nl\r
+"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."\r
+{ $heading "BSD" }\r
+"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."\r
+$nl\r
+"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."\r
+{ $heading "Windows CE" }\r
+"Windows CE does not support monitors." ;\r
\r
ARTICLE: "io.monitors" "File system change monitors"\r
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."\r
$nl\r
+"Monitoring operations must be wrapped in a combinator:"\r
+{ $subsection with-monitors }\r
"Creating a file system change monitor and listening for changes:"\r
{ $subsection <monitor> }\r
{ $subsection next-change }\r
+"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"\r
+{ $subsection (monitor) }\r
{ $subsection "io.monitors.descriptors" }\r
-"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."\r
-$nl\r
-"A utility combinator which opens a monitor and cleans it up after:"\r
+{ $subsection "io.monitors.platforms" } \r
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"\r
{ $subsection with-monitor }\r
-"An example which watches the Factor directory for changes:"\r
+"Monitors support the " { $link "io.timeouts" } "."\r
+$nl\r
+"An example which watches a directory for changes:"\r
{ $code\r
"USE: io.monitors"\r
": watch-loop ( monitor -- )"\r
" dup next-change . . nl nl flush watch-loop ;"\r
""\r
- "\"\" resource-path f [ watch-loop ] with-monitor"\r
+ ": watch-directory ( path -- )"\r
+ " [ t [ watch-loop ] with-monitor ] with-monitors"\r
} ;\r
\r
ABOUT: "io.monitors"\r
--- /dev/null
+IN: io.monitors.tests
+USING: io.monitors tools.test io.files system sequences
+continuations namespaces concurrency.count-downs kernel io
+threads calendar prettyprint ;
+
+os { winnt linux macosx } member? [
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+
+
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ 1 <count-down> "b" set ] unit-test
+
+ [ ] [ 1 <count-down> "c1" set ] unit-test
+
+ [ ] [ 1 <count-down> "c2" set ] unit-test
+
+ [ ] [
+ [
+ "b" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "xyz" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c1" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "yxy" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c2" get count-down
+ ] "Monitor test thread" spawn drop
+ ] unit-test
+
+ [ ] [ "b" get await ] unit-test
+
+ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c1" get 1 minutes await-timeout ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c2" get 1 minutes await-timeout ] unit-test
+
+ ! Dispose twice
+ [ ] [ "m" get dispose ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+] when
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: io.backend kernel continuations namespaces sequences\r
-assocs hashtables sorting arrays threads boxes io.timeouts ;\r
-IN: io.monitors\r
-\r
-<PRIVATE\r
-\r
-TUPLE: monitor queue closed? ;\r
-\r
-: check-monitor ( monitor -- )\r
- monitor-closed? [ "Monitor closed" throw ] when ;\r
-\r
-: (monitor) ( delegate -- monitor )\r
- H{ } clone {\r
- set-delegate\r
- set-monitor-queue\r
- } monitor construct ;\r
-\r
-GENERIC: fill-queue ( monitor -- )\r
-\r
-: changed-file ( changed path -- )\r
- namespace [ append ] change-at ;\r
-\r
-: dequeue-change ( assoc -- path changes )\r
- delete-any prune natural-sort >array ;\r
-\r
-M: monitor dispose\r
- dup check-monitor\r
- t over set-monitor-closed?\r
- delegate dispose ;\r
-\r
-! Simple monitor; used on Linux and Mac OS X. On Windows,\r
-! monitors are full-fledged ports.\r
-TUPLE: simple-monitor handle callback timeout ;\r
-\r
-M: simple-monitor timeout simple-monitor-timeout ;\r
-\r
-M: simple-monitor set-timeout set-simple-monitor-timeout ;\r
-\r
-: <simple-monitor> ( handle -- simple-monitor )\r
- f (monitor) <box> {\r
- set-simple-monitor-handle\r
- set-delegate\r
- set-simple-monitor-callback\r
- } simple-monitor construct ;\r
-\r
-: construct-simple-monitor ( handle class -- simple-monitor )\r
- >r <simple-monitor> r> construct-delegate ; inline\r
-\r
-: notify-callback ( simple-monitor -- )\r
- simple-monitor-callback [ resume ] if-box? ;\r
-\r
-M: simple-monitor timed-out\r
- notify-callback ;\r
-\r
-M: simple-monitor fill-queue ( monitor -- )\r
- [\r
- [ swap simple-monitor-callback >box ]\r
- "monitor" suspend drop\r
- ] with-timeout\r
- check-monitor ;\r
-\r
-M: simple-monitor dispose ( monitor -- )\r
- dup delegate dispose notify-callback ;\r
-\r
-PRIVATE>\r
-\r
-HOOK: <monitor> io-backend ( path recursive? -- monitor )\r
-\r
-: next-change ( monitor -- path changed )\r
- dup check-monitor\r
- dup monitor-queue dup assoc-empty? [\r
- drop dup fill-queue next-change\r
- ] [ nip dequeue-change ] if ;\r
-\r
-SYMBOL: +add-file+\r
-SYMBOL: +remove-file+\r
-SYMBOL: +modify-file+\r
-SYMBOL: +rename-file+\r
-\r
-: with-monitor ( path recursive? quot -- )\r
- >r <monitor> r> with-disposal ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend kernel continuations namespaces sequences
+assocs hashtables sorting arrays threads boxes io.timeouts
+accessors concurrency.mailboxes ;
+IN: io.monitors
+
+HOOK: init-monitors io-backend ( -- )
+
+M: object init-monitors ;
+
+HOOK: dispose-monitors io-backend ( -- )
+
+M: object dispose-monitors ;
+
+: with-monitors ( quot -- )
+ [
+ init-monitors
+ [ dispose-monitors ] [ ] cleanup
+ ] with-scope ; inline
+
+TUPLE: monitor < identity-tuple path queue timeout ;
+
+M: monitor hashcode* path>> hashcode* ;
+
+M: monitor timeout timeout>> ;
+
+M: monitor set-timeout (>>timeout) ;
+
+: new-monitor ( path mailbox class -- monitor )
+ new
+ swap >>queue
+ swap >>path ; inline
+
+: queue-change ( path changes monitor -- )
+ 3dup and and
+ [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
+
+HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
+
+: <monitor> ( path recursive? -- monitor )
+ <mailbox> (monitor) ;
+
+: next-change ( monitor -- path changed )
+ [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
+
+SYMBOL: +add-file+
+SYMBOL: +remove-file+
+SYMBOL: +modify-file+
+SYMBOL: +rename-file-old+
+SYMBOL: +rename-file-new+
+SYMBOL: +rename-file+
+
+: with-monitor ( path recursive? quot -- )
+ >r <monitor> r> with-disposal ; inline
--- /dev/null
+USING: accessors math kernel namespaces continuations
+io.files io.monitors io.monitors.recursive io.backend
+concurrency.mailboxes
+tools.test ;
+IN: io.monitors.recursive.tests
+
+\ pump-thread must-infer
+
+SINGLETON: mock-io-backend
+
+TUPLE: counter i ;
+
+SYMBOL: dummy-monitor-created
+SYMBOL: dummy-monitor-disposed
+
+TUPLE: dummy-monitor < monitor ;
+
+M: dummy-monitor dispose
+ drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+
+M: mock-io-backend (monitor)
+ nip
+ over exists? [
+ dummy-monitor new-monitor
+ dummy-monitor-created get [ 1+ ] change-i drop
+ ] [
+ "Does not exist" throw
+ ] if ;
+
+M: mock-io-backend link-info
+ global [ link-info ] bind ;
+
+[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
+[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] unit-test
+
+[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
+
+[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
+
+[ "doesnotexist" temp-file delete-tree ] ignore-errors
+
+[
+ mock-io-backend io-backend [
+ "doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] must-fail
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor>
+ [ dispose ] [ dispose ] bi
+ ] with-variable
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences assocs arrays continuations combinators kernel
+threads concurrency.messaging concurrency.mailboxes
+concurrency.promises
+io.files io.monitors ;
+IN: io.monitors.recursive
+
+! Simulate recursive monitors on platforms that don't have them
+
+TUPLE: recursive-monitor < monitor children thread ready ;
+
+DEFER: add-child-monitor
+
+: qualify-path ( path -- path' )
+ monitor tget path>> prepend-path ;
+
+: add-child-monitors ( path -- )
+ #! We yield since this directory scan might take a while.
+ [
+ directory* [ first add-child-monitor yield ] each
+ ] curry ignore-errors ;
+
+: add-child-monitor ( path -- )
+ qualify-path dup link-info type>> +directory+ eq? [
+ [ add-child-monitors ]
+ [
+ [ f my-mailbox (monitor) ] keep
+ monitor tget children>> set-at
+ ] bi
+ ] [ drop ] if ;
+
+USE: io
+USE: prettyprint
+
+: remove-child-monitor ( monitor -- )
+ monitor tget children>> delete-at*
+ [ dispose ] [ drop ] if ;
+
+M: recursive-monitor dispose
+ dup queue>> closed>> [
+ drop
+ ] [
+ [ "stop" swap thread>> send-synchronous drop ]
+ [ queue>> dispose ] bi
+ ] if ;
+
+: stop-pump ( -- )
+ monitor tget children>> [ nip dispose ] assoc-each ;
+
+: pump-step ( msg -- )
+ first3 path>> swap >r prepend-path r> monitor tget 3array
+ monitor tget queue>>
+ mailbox-put ;
+
+: child-added ( path monitor -- )
+ path>> prepend-path add-child-monitor ;
+
+: child-removed ( path monitor -- )
+ path>> prepend-path remove-child-monitor ;
+
+: update-hierarchy ( msg -- )
+ first3 swap [
+ {
+ { +add-file+ [ child-added ] }
+ { +remove-file+ [ child-removed ] }
+ { +rename-file-old+ [ child-removed ] }
+ { +rename-file-new+ [ child-added ] }
+ [ 3drop ]
+ } case
+ ] with with each ;
+
+: pump-loop ( -- )
+ receive dup synchronous? [
+ >r stop-pump t r> reply-synchronous
+ ] [
+ [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
+ pump-loop
+ ] if ;
+
+: monitor-ready ( error/t -- )
+ monitor tget ready>> fulfill ;
+
+: pump-thread ( monitor -- )
+ monitor tset
+ [ "" add-child-monitor t monitor-ready ]
+ [ [ self <linked-error> monitor-ready ] keep rethrow ]
+ recover
+ pump-loop ;
+
+: start-pump-thread ( monitor -- )
+ dup [ pump-thread ] curry
+ "Recursive monitor pump" spawn
+ >>thread drop ;
+
+: wait-for-ready ( monitor -- )
+ ready>> ?promise ?linked drop ;
+
+: <recursive-monitor> ( path mailbox -- monitor )
+ >r (normalize-path) r>
+ recursive-monitor new-monitor
+ H{ } clone >>children
+ <promise> >>ready
+ dup start-pump-thread
+ dup wait-for-ready ;
USING: io io.buffers io.backend help.markup help.syntax kernel
-byte-arrays sbufs words continuations byte-vectors ;
+byte-arrays sbufs words continuations byte-vectors classes ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
$nl
"Ports have the following slots:"
{ $list
- { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
- { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
- { { $link port-type } " - a symbol identifying the port's intended purpose" }
- { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
+ { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
+ { { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
+ { { $snippet "type" } " - a symbol identifying the port's intended purpose" }
+ { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
HELP: input-port
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
-{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
+{ $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ;
HELP: <buffered-port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: can-write?
-{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
+{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-IN: io.nonblocking
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
-splitting dlists assocs io.encodings.binary ;
+splitting dlists assocs io.encodings.binary inspector accessors ;
+IN: io.nonblocking
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
-! Common delegate of native stream readers and writers
-TUPLE: port
-handle
-error
-timeout
-type eof? ;
-
-M: port timeout port-timeout ;
-
-M: port set-timeout set-port-timeout ;
+TUPLE: port handle buffer error timeout closed eof ;
-SYMBOL: closed
+M: port timeout timeout>> ;
-PREDICATE: input-port < port port-type input-port eq? ;
-PREDICATE: output-port < port port-type output-port eq? ;
+M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
+
GENERIC: close-handle ( handle -- )
-: <port> ( handle buffer type -- port )
- pick init-handle {
- set-port-handle
- set-delegate
- set-port-type
- } port construct ;
+: <port> ( handle class -- port )
+ new
+ swap dup init-handle >>handle ; inline
+
+: <buffered-port> ( handle class -- port )
+ <port>
+ default-buffer-size get <buffer> >>buffer ; inline
-: <buffered-port> ( handle type -- port )
- default-buffer-size get <buffer> swap <port> ;
+TUPLE: input-port < port ;
: <reader> ( handle -- input-port )
input-port <buffered-port> ;
+TUPLE: output-port < port ;
+
: <writer> ( handle -- output-port )
output-port <buffered-port> ;
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- )
- dup port-error f rot set-port-error [ throw ] when* ;
+ [ f ] change-error drop [ throw ] when* ;
+
+ERROR: port-closed-error port ;
+
+M: port-closed-error summary
+ drop "Port has been closed" ;
+
+: check-closed ( port -- port )
+ dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- )
GENERIC: (wait-to-read) ( port -- )
: wait-to-read ( count port -- )
- tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
+ tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: unless-eof ( port quot -- value )
- >r dup buffer-empty? over port-eof? and
- [ f swap set-port-eof? f ] r> if ; inline
+ >r dup buffer>> buffer-empty? over eof>> and
+ [ f >>eof drop f ] r> if ; inline
M: input-port stream-read1
- dup wait-to-read1 [ buffer-pop ] unless-eof ;
+ check-closed
+ dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
- [ dupd buffer-read ] unless-eof nip ;
+ [ dupd buffer>> buffer-read ] unless-eof nip ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
] if ;
M: input-port stream-read
+ check-closed
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
[ push-all ] keep
[ read-loop ] keep
B{ } like
- ] [
- 2nip
- ] if
- ] [
- 2nip
- ] if ;
+ ] [ 2nip ] if
+ ] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
+ check-closed
>r 0 max >fixnum r> read-step ;
-: can-write? ( len writer -- ? )
+: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- )
- tuck can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
- 1 over wait-to-write byte>buffer ;
+ check-closed
+ 1 over wait-to-write
+ buffer>> byte>buffer ;
M: output-port stream-write
- over length over buffer-size > [
- [ buffer-size <groups> ] keep
- [ stream-write ] curry each
+ check-closed
+ over length over buffer>> buffer-size > [
+ [ buffer>> buffer-size <groups> ]
+ [ [ stream-write ] curry ] bi
+ each
] [
- over length over wait-to-write >buffer
+ [ >r length r> wait-to-write ]
+ [ buffer>> >buffer ] 2bi
] if ;
GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
- dup port-flush pending-error ;
+ check-closed
+ [ port-flush ] [ pending-error ] bi ;
+
+GENERIC: close-port ( port -- )
+
+M: output-port close-port
+ [ port-flush ] [ call-next-method ] bi ;
-: close-port ( port type -- )
- output-port eq? [ dup port-flush ] when
+M: port close-port
dup cancel-io
- dup port-handle close-handle
- dup delegate [ buffer-free ] when*
- f swap set-delegate ;
+ dup handle>> close-handle
+ [ [ buffer-free ] when* f ] change-buffer drop ;
M: port dispose
- dup port-type closed eq?
- [ drop ]
- [ dup port-type >r closed over set-port-type r> close-port ]
- if ;
+ dup closed>> [ drop ] [ t >>closed close-port ] if ;
-TUPLE: server-port addr client client-addr encoding ;
+TUPLE: server-port < port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server )
- rot
f server-port <port>
- { set-server-port-addr set-server-port-encoding set-delegate }
- server-port construct ;
+ rot server-port <port>
+ swap >>encoding
+ swap >>addr ;
-: check-server-port ( port -- )
- port-type server-port assert= ;
+: check-server-port ( port -- port )
+ dup server-port? [ "Not a server port" throw ] unless ; inline
-TUPLE: datagram-port addr packet packet-addr ;
+TUPLE: datagram-port < port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram )
- >r f datagram-port <port> r>
- { set-delegate set-datagram-port-addr }
- datagram-port construct ;
+ swap datagram-port <port>
+ swap >>addr ;
-: check-datagram-port ( port -- )
- port-type datagram-port assert= ;
+: check-datagram-port ( port -- port )
+ check-closed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-: check-datagram-send ( packet addrspec port -- )
- dup check-datagram-port
- datagram-port-addr [ class ] bi@ assert=
- class byte-array assert= ;
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
] curry each ;
: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator construct-boa
+ <dlist> directory-iterator boa
dup path>> over push-directory ;
: next-file ( iter -- file/f )
LOG: accepted-connection NOTICE
-: with-client ( client quot -- )
+: with-client ( client addrspec quot -- )
[
- over client-stream-addr accepted-connection
+ swap accepted-connection
with-stream*
- ] curry with-disposal ; inline
+ ] 2curry with-disposal ; inline
\ with-client DEBUG add-error-logging
: accept-loop ( server quot -- )
[
- >r accept r> [ with-client ] 2curry "Client" spawn drop
+ >r accept r> [ with-client ] 3curry "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
{ [ dup AF_INET = ] [ T{ inet4 } ] }
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
{ [ dup AF_UNIX = ] [ T{ local } ] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
M: f parse-sockaddr nip ;
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> }
{ $subsection accept }
-"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
-{ $subsection client-stream-addr }
"Server sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept
-{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
-{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
-$nl
-"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
+{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
+{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
HELP: <datagram>
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
-sequences arrays io.encodings io.nonblocking ;
+sequences arrays io.encodings io.nonblocking accessors ;
IN: io.sockets
TUPLE: local path ;
: <local> ( path -- addrspec )
- normalize-path local construct-boa ;
+ normalize-path local boa ;
TUPLE: inet4 host port ;
C: <inet> inet
-TUPLE: client-stream addr ;
+HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
-: <client-stream> ( addrspec delegate -- stream )
- { set-client-stream-addr set-delegate }
- client-stream construct ;
-
-HOOK: (client) io-backend ( addrspec -- client-in client-out )
-
-GENERIC: client* ( addrspec -- client-in client-out )
-M: array client* [ (client) 2array ] attempt-all first2 ;
-M: object client* (client) ;
+GENERIC: (client) ( addrspec -- client-in client-out )
+M: array (client) [ ((client)) 2array ] attempt-all first2 ;
+M: object (client) ((client)) ;
: <client> ( addrspec encoding -- stream )
- >r client* r> <encoder-duplex> ;
+ >r (client) r> <encoder-duplex> ;
HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
-: accept ( server -- client )
- [ (accept) dup <reader&writer> ] keep
- server-port-encoding <encoder-duplex>
- <client-stream> ;
+: accept ( server -- client addrspec )
+ [ (accept) dup <reader&writer> ] [ encoding>> ] bi
+ <encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
HOOK: host-name io-backend ( -- string )
-M: inet client*
- dup inet-host swap inet-port f resolve-host
- dup empty? [ "Host name lookup failed" throw ] when
- client* ;
+M: inet (client)
+ [ host>> ] [ port>> ] bi f resolve-host
+ [ empty? [ "Host name lookup failed" throw ] when ]
+ [ (client) ]
+ bi ;
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;\r
\r
ARTICLE: "io.timeouts" "I/O timeout protocol"\r
-"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
+"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
{ $subsection timeout }\r
{ $subsection set-timeout }\r
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."\r
{ $subsection timed-out }\r
"A combinator to be used in operations which can time out:"\r
{ $subsection with-timeout }\r
-{ $see-also "stream-protocol" "io.launcher" } ;\r
+{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;\r
\r
ABOUT: "io.timeouts"\r
: io-task-fd port>> handle>> ;
: <io-task> ( port continuation/f class -- task )
- >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
- r> construct-delegate ; inline
+ new
+ swap [ 1vector ] [ V{ } clone ] if* >>callbacks
+ swap >>port ; inline
-TUPLE: input-task ;
+TUPLE: input-task < io-task ;
-: <input-task> ( port continuation class -- task )
- >r input-task <io-task> r> construct-delegate ; inline
-
-TUPLE: output-task ;
-
-: <output-task> ( port continuation class -- task )
- >r output-task <io-task> r> construct-delegate ; inline
+TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
M: output-task io-task-container drop writes>> ;
-: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
-
-: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
+: new-mx ( class -- obj )
+ new
+ H{ } clone >>reads
+ H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- )
GENERIC: unregister-io-task ( task mx -- )
! Readers
: reader-eof ( reader -- )
- dup buffer-empty? [ t >>eof? ] when drop ;
+ dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
- [ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
+ [ handle>> ]
+ [ buffer>> buffer-end ]
+ [ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? )
#! Return f if there is a recoverable error
- dup buffer-empty? [
+ dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
- swap n>buffer t
+ swap buffer>> n>buffer t
] [
drop defer-error
] if
drop t
] if ;
-TUPLE: read-task ;
+TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task )
- read-task <input-task> ;
+ read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
! Writers
: write-step ( port -- ? )
- dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
- dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
+ dup
+ [ handle>> ]
+ [ buffer>> buffer@ ]
+ [ buffer>> buffer-length ] tri
+ write dup 0 >=
+ [ swap buffer>> buffer-consume f ]
+ [ drop defer-error ] if ;
-TUPLE: write-task ;
+TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task )
- write-task <output-task> ;
+ write-task <io-task> ;
M: write-task do-io-task
- io-task-port dup [ buffer-empty? ] [ port-error ] bi or
- [ 0 swap buffer-reset t ] [ write-step ] if ;
+ io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
+ [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
: add-write-io-task ( port continuation -- )
- over port-handle mx get-global mx-writes at*
+ over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task ] with-port-continuation drop ;
-M: port port-flush ( port -- )
- dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
+M: output-port port-flush ( port -- )
+ dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
2 <writer> ;
! mx io-task for embedding an fd-based mx inside another mx
-TUPLE: mx-port mx ;
+TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
- dup fd>> f mx-port <port>
- { set-mx-port-mx set-delegate } mx-port construct ;
+ dup fd>> mx-port <port> swap >>mx ;
-TUPLE: mx-task ;
+TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;
: multiplexer-error ( n -- )
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
+
+: ?flag ( n mask symbol -- n )
+ pick rot bitand 0 > [ , ] [ drop ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
-USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
-io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations system ;
-
-! On Mac OS X, we use select() for the top-level
-! multiplexer, and we hang a kqueue off of it for process exit
-! notification.
-
-! kqueue is buggy with files and ptys so we can't use it as the
-! main multiplexer.
+USING: namespaces system kernel accessors assocs continuations
+unix
+io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
M: bsd init-io ( -- )
<select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global
- kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
- 2dup mx get-global mx-reads set-at
- mx get-global mx-writes set-at ;
+ kqueue-mx get-global <mx-port> <mx-task>
+ dup io-task-fd
+ [ mx get-global reads>> set-at ]
+ [ mx get-global writes>> set-at ] 2bi ;
-M: bsd register-process ( process -- )
- process-handle kqueue-mx get-global add-pid-task ;
+M: bsd (monitor) ( path recursive? mailbox -- )
+ swap [ "Recursive kqueue monitors not supported" throw ] when
+ <vnode-monitor> ;
namespaces structs ;
IN: io.unix.epoll
-TUPLE: epoll-mx events ;
+TUPLE: epoll-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <epoll-mx> ( -- mx )
- epoll-mx construct-mx
+ epoll-mx new-mx
max-events epoll_create dup io-error over set-mx-fd
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- )
- 2dup EPOLL_CTL_ADD do-epoll-ctl
- delegate register-io-task ;
+ [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
M: epoll-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- EPOLL_CTL_DEL do-epoll-ctl ;
+ [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
: wait-event ( mx timeout -- n )
>r { mx-fd epoll-mx-events } get-slots max-events
M: unix copy-file ( from to -- )
[ normalize-path ] bi@
[ (copy-file) ]
- [ swap file-info file-info-permissions chmod io-error ]
+ [ swap file-info permissions>> chmod io-error ]
2bi ;
: stat>type ( stat -- type )
- stat-st_mode {
- { [ dup S_ISREG ] [ +regular-file+ ] }
- { [ dup S_ISDIR ] [ +directory+ ] }
- { [ dup S_ISCHR ] [ +character-device+ ] }
- { [ dup S_ISBLK ] [ +block-device+ ] }
- { [ dup S_ISFIFO ] [ +fifo+ ] }
- { [ dup S_ISLNK ] [ +symbolic-link+ ] }
- { [ dup S_ISSOCK ] [ +socket+ ] }
- { [ t ] [ +unknown+ ] }
- } cond nip ;
+ stat-st_mode S_IFMT bitand {
+ { S_IFREG [ +regular-file+ ] }
+ { S_IFDIR [ +directory+ ] }
+ { S_IFCHR [ +character-device+ ] }
+ { S_IFBLK [ +block-device+ ] }
+ { S_IFIFO [ +fifo+ ] }
+ { S_IFLNK [ +symbolic-link+ ] }
+ { S_IFSOCK [ +socket+ ] }
+ [ drop +unknown+ ]
+ } case ;
: stat>file-info ( stat -- info )
{
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io.nonblocking io.unix.backend
-sequences assocs unix unix.time unix.kqueue unix.process math namespaces
-combinators threads vectors io.launcher
-io.unix.launcher ;
+USING: alien.c-types kernel math math.bitfields namespaces
+locals accessors combinators threads vectors hashtables
+sequences assocs continuations sets
+unix unix.time unix.kqueue unix.process
+io.nonblocking io.unix.backend io.launcher io.unix.launcher
+io.monitors ;
IN: io.unix.kqueue
-TUPLE: kqueue-mx events ;
+TUPLE: kqueue-mx < mx events monitors ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <kqueue-mx> ( -- mx )
- kqueue-mx construct-mx
- kqueue dup io-error over set-mx-fd
- max-events "kevent" <c-array> over set-kqueue-mx-events ;
+ kqueue-mx new-mx
+ H{ } clone >>monitors
+ kqueue dup io-error >>fd
+ max-events "kevent" <c-array> >>events ;
GENERIC: io-task-filter ( task -- n )
M: output-task io-task-filter drop EVFILT_WRITE ;
+GENERIC: io-task-fflags ( task -- n )
+
+M: io-task io-task-fflags drop 0 ;
+
: make-kevent ( task flags -- event )
"kevent" <c-object>
tuck set-kevent-flags
over io-task-fd over set-kevent-ident
+ over io-task-fflags over set-kevent-fflags
swap io-task-filter over set-kevent-filter ;
: register-kevent ( kevent mx -- )
- mx-fd swap 1 f 0 f kevent
+ fd>> swap 1 f 0 f kevent
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
- over EV_ADD make-kevent over register-kevent
- delegate register-io-task ;
+ [ >r EV_ADD make-kevent r> register-kevent ]
+ [ call-next-method ]
+ 2bi ;
M: kqueue-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- swap EV_DELETE make-kevent swap register-kevent ;
+ [ call-next-method ]
+ [ >r EV_DELETE make-kevent r> register-kevent ]
+ 2bi ;
: wait-kevent ( mx timespec -- n )
- >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
+ >r [ fd>> f 0 ] keep events>> max-events r> kevent
dup multiplexer-error ;
-: kevent-read-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-read-task ( mx fd kevent -- )
+ mx fd mx reads>> at handle-io-task ;
-: kevent-write-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-write-task ( mx fd kevent -- )
+ mx fd mx writes>> at handle-io-task ;
-: kevent-proc-task ( pid -- )
- dup wait-for-pid swap find-process
+:: kevent-proc-task ( mx pid kevent -- )
+ pid wait-for-pid
+ pid find-process
dup [ swap notify-exit ] [ 2drop ] if ;
+: parse-action ( mask -- changed )
+ [
+ NOTE_DELETE +remove-file+ ?flag
+ NOTE_WRITE +modify-file+ ?flag
+ NOTE_EXTEND +modify-file+ ?flag
+ NOTE_ATTRIB +modify-file+ ?flag
+ NOTE_RENAME +rename-file+ ?flag
+ NOTE_REVOKE +remove-file+ ?flag
+ drop
+ ] { } make prune ;
+
+:: kevent-vnode-task ( mx kevent fd -- )
+ ""
+ kevent kevent-fflags parse-action
+ fd mx monitors>> at queue-change ;
+
: handle-kevent ( mx kevent -- )
- dup kevent-ident swap kevent-filter {
+ [ ] [ kevent-ident ] [ kevent-filter ] tri {
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
- { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
+ { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+ { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
} cond ;
: handle-kevents ( mx n -- )
- [ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
+ [ over events>> kevent-nth handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( ms mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
+! Procs
: make-proc-kevent ( pid -- kevent )
"kevent" <c-object>
tuck set-kevent-ident
EVFILT_PROC over set-kevent-filter
NOTE_EXIT over set-kevent-fflags ;
-: add-pid-task ( pid mx -- )
+: register-pid-task ( pid mx -- )
swap make-proc-kevent swap register-kevent ;
+
+! VNodes
+TUPLE: vnode-monitor < monitor fd ;
+
+: vnode-fflags ( -- n )
+ {
+ NOTE_DELETE
+ NOTE_WRITE
+ NOTE_EXTEND
+ NOTE_ATTRIB
+ NOTE_LINK
+ NOTE_RENAME
+ NOTE_REVOKE
+ } flags ;
+
+: make-vnode-kevent ( fd flags -- kevent )
+ "kevent" <c-object>
+ tuck set-kevent-flags
+ tuck set-kevent-ident
+ EVFILT_VNODE over set-kevent-filter
+ vnode-fflags over set-kevent-fflags ;
+
+: register-monitor ( monitor mx -- )
+ >r dup fd>> r>
+ [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
+ [ monitors>> set-at ] 3bi ;
+
+: unregister-monitor ( monitor mx -- )
+ >r fd>> r>
+ [ monitors>> delete-at ]
+ [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
+
+: <vnode-monitor> ( path mailbox -- monitor )
+ >r [ O_RDONLY 0 open dup io-error ] keep r>
+ vnode-monitor new-monitor swap >>fd
+ [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
+
+M: vnode-monitor dispose
+ [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
-: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ;
+: reset-fd ( fd -- )
+ #! We drop the error code because on *BSD, fcntl of
+ #! /dev/null fails.
+ F_SETFL 0 fcntl drop ;
: redirect-inherit ( obj mode fd -- )
2nip reset-fd ;
{ [ pick string? ] [ redirect-file ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick +inherit+ eq? ] [ redirect-closed ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
?closed write-flags 2 redirect
] if ;
+: setup-environment ( process -- process )
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when ;
+
: spawn-process ( process -- * )
- [
- setup-priority
- setup-redirection
- current-directory get resource-path cd
- dup pass-environment? [
- dup get-environment set-os-envs
- ] when
-
- get-arguments exec-args-with-path
- (io-error)
- ] [ 255 exit ] recover ;
+ [ setup-priority ] [ 250 _exit ] recover
+ [ setup-redirection ] [ 251 _exit ] recover
+ [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
+ [ setup-environment ] [ 253 _exit ] recover
+ [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
+ 255 _exit ;
M: unix current-process-handle ( -- handle ) getpid ;
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
-: wait-for-processes ( -- ? )
+M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
2drop f
] if
] if ;
-
-: start-wait-thread ( -- )
- [ wait-for-processes [ 250 sleep ] when t ]
- "Process reaper" spawn-server drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.private
-io.files io.buffers io.nonblocking io.timeouts io.unix.backend
-io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math alien.c-types alien
-vocabs.loader accessors system ;
+USING: kernel io.backend io.monitors io.unix.backend
+io.unix.select io.unix.linux.monitors system namespaces ;
IN: io.unix.linux
-TUPLE: linux-monitor ;
-
-: <linux-monitor> ( wd -- monitor )
- linux-monitor construct-simple-monitor ;
-
-TUPLE: inotify watches ;
-
-: watches ( -- assoc ) inotify get-global watches>> ;
-
-: wd>monitor ( wd -- monitor ) watches at ;
-
-: <inotify> ( -- port/f )
- H{ } clone
- inotify_init dup 0 < [ 2drop f ] [
- inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct
- ] if ;
-
-: inotify-fd inotify get-global handle>> ;
-
-: (add-watch) ( path mask -- wd )
- inotify-fd -rot inotify_add_watch dup io-error ;
-
-: check-existing ( wd -- )
- watches key? [
- "Cannot open multiple monitors for the same file" throw
- ] when ;
-
-: add-watch ( path mask -- monitor )
- (add-watch) dup check-existing
- [ <linux-monitor> dup ] keep watches set-at ;
-
-: remove-watch ( monitor -- )
- dup simple-monitor-handle watches delete-at
- simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
-
-: check-inotify
- inotify get [
- "inotify is not supported by this Linux release" throw
- ] unless ;
-
-M: linux <monitor> ( path recursive? -- monitor )
- check-inotify
- drop IN_CHANGE_EVENTS add-watch ;
-
-M: linux-monitor dispose ( monitor -- )
- dup delegate dispose remove-watch ;
-
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
-
-: parse-action ( mask -- changed )
- [
- IN_CREATE +add-file+ ?flag
- IN_DELETE +remove-file+ ?flag
- IN_DELETE_SELF +remove-file+ ?flag
- IN_MODIFY +modify-file+ ?flag
- IN_ATTRIB +modify-file+ ?flag
- IN_MOVED_FROM +rename-file+ ?flag
- IN_MOVED_TO +rename-file+ ?flag
- IN_MOVE_SELF +rename-file+ ?flag
- drop
- ] { } make ;
-
-: parse-file-notify ( buffer -- changed path )
- { inotify-event-name inotify-event-mask } get-slots
- parse-action swap alien>char-string ;
-
-: events-exhausted? ( i buffer -- ? )
- fill>> >= ;
-
-: inotify-event@ ( i buffer -- alien )
- ptr>> <displaced-alien> ;
-
-: next-event ( i buffer -- i buffer )
- 2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
- swap >r + r> ;
-
-: parse-file-notifications ( i buffer -- )
- 2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor [
- monitor-queue [
- parse-file-notify changed-file
- ] bind
- ] keep notify-callback
- next-event parse-file-notifications
- ] if ;
-
-: read-notifications ( port -- )
- dup refill drop
- 0 over parse-file-notifications
- 0 swap buffer-reset ;
-
-TUPLE: inotify-task ;
-
-: <inotify-task> ( port -- task )
- f inotify-task <input-task> ;
-
-: init-inotify ( mx -- )
- <inotify> dup [
- dup inotify set-global
- <inotify-task> swap register-io-task
- ] [
- 2drop
- ] if ;
-
-M: inotify-task do-io-task ( task -- )
- io-task-port read-notifications f ;
-
M: linux init-io ( -- )
- <select-mx>
- [ mx set-global ]
- [ init-inotify ] bi ;
+ <select-mx> mx set-global ;
linux set-io-backend
-
-[ start-wait-thread ] "io.unix.linux" add-init-hook
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.backend io.monitors io.monitors.recursive
+io.files io.buffers io.monitors io.nonblocking io.timeouts
+io.unix.backend io.unix.select unix.linux.inotify assocs
+namespaces threads continuations init math math.bitfields sets
+alien.c-types alien vocabs.loader accessors system hashtables ;
+IN: io.unix.linux.monitors
+
+TUPLE: linux-monitor < monitor wd ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ swap >>wd ;
+
+SYMBOL: watches
+
+SYMBOL: inotify
+
+: wd>monitor ( wd -- monitor ) watches get at ;
+
+: <inotify> ( -- port/f )
+ inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
+
+: inotify-fd inotify get handle>> ;
+
+: check-existing ( wd -- )
+ watches get key? [
+ "Cannot open multiple monitors for the same file" throw
+ ] when ;
+
+: (add-watch) ( path mask -- wd )
+ inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
+
+: add-watch ( path mask mailbox -- monitor )
+ >r
+ >r (normalize-path) r>
+ [ (add-watch) ] [ drop ] 2bi r>
+ <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
+
+: check-inotify
+ inotify get [
+ "Calling <monitor> outside with-monitors" throw
+ ] unless ;
+
+M: linux (monitor) ( path recursive? mailbox -- monitor )
+ swap [
+ <recursive-monitor>
+ ] [
+ check-inotify
+ IN_CHANGE_EVENTS swap add-watch
+ ] if ;
+
+M: linux-monitor dispose ( monitor -- )
+ [ wd>> watches get delete-at ]
+ [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
+
+: ignore-flags? ( mask -- ? )
+ {
+ IN_DELETE_SELF
+ IN_MOVE_SELF
+ IN_UNMOUNT
+ IN_Q_OVERFLOW
+ IN_IGNORED
+ } flags bitand 0 > ;
+
+: parse-action ( mask -- changed )
+ [
+ IN_CREATE +add-file+ ?flag
+ IN_DELETE +remove-file+ ?flag
+ IN_MODIFY +modify-file+ ?flag
+ IN_ATTRIB +modify-file+ ?flag
+ IN_MOVED_FROM +rename-file-old+ ?flag
+ IN_MOVED_TO +rename-file-new+ ?flag
+ drop
+ ] { } make prune ;
+
+: parse-file-notify ( buffer -- path changed )
+ dup inotify-event-mask ignore-flags? [
+ drop f f
+ ] [
+ [ inotify-event-name alien>char-string ]
+ [ inotify-event-mask parse-action ] bi
+ ] if ;
+
+: events-exhausted? ( i buffer -- ? )
+ fill>> >= ;
+
+: inotify-event@ ( i buffer -- alien )
+ ptr>> <displaced-alien> ;
+
+: next-event ( i buffer -- i buffer )
+ 2dup inotify-event@
+ inotify-event-len "inotify-event" heap-size +
+ swap >r + r> ;
+
+: parse-file-notifications ( i buffer -- )
+ 2dup events-exhausted? [ 2drop ] [
+ 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ >r parse-file-notify r> queue-change
+ next-event parse-file-notifications
+ ] if ;
+
+: inotify-read-loop ( port -- )
+ dup wait-to-read1
+ 0 over buffer>> parse-file-notifications
+ 0 over buffer>> buffer-reset
+ inotify-read-loop ;
+
+: inotify-read-thread ( port -- )
+ [ inotify-read-loop ] curry ignore-errors ;
+
+M: linux init-monitors
+ H{ } clone watches set
+ <inotify> [
+ [ inotify set ]
+ [
+ [ inotify-read-thread ] curry
+ "Linux monitor thread" spawn drop
+ ] bi
+ ] [
+ "Linux kernel version is too old" throw
+ ] if* ;
+
+M: linux dispose-monitors
+ inotify get dispose ;
-USING: io.unix.bsd io.backend io.monitors io.monitors.private
-continuations kernel core-foundation.fsevents sequences
-namespaces arrays system ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
+continuations kernel sequences namespaces arrays system locals
+accessors ;
IN: io.unix.macosx
-macosx set-io-backend
-
-TUPLE: macosx-monitor ;
+TUPLE: macosx-monitor < monitor handle ;
: enqueue-notifications ( triples monitor -- )
- tuck monitor-queue
- [ [ first { +modify-file+ } swap changed-file ] each ] bind
- notify-callback ;
+ [
+ >r first { +modify-file+ } r> queue-change
+ ] curry each ;
-M: macosx <monitor>
- drop
- f macosx-monitor construct-simple-monitor
+M:: macosx (monitor) ( path recursive? mailbox -- monitor )
+ path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
- rot 1array 0 0 <event-stream>
- over set-simple-monitor-handle ;
+ path 1array 0 0 <event-stream> >>handle ;
M: macosx-monitor dispose
- dup simple-monitor-handle dispose delegate dispose ;
+ handle>> dispose ;
+
+macosx set-io-backend
M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
- r> mmap-open f mapped-file construct-boa ;
+ r> mmap-open f mapped-file boa ;
M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
-USING: io.backend system ;
+USING: io.unix.bsd io.backend system ;
netbsd set-io-backend
-USING: io.unix.bsd io.backend core-foundation.fsevents system ;
+USING: io.unix.bsd io.backend system ;
openbsd set-io-backend
accessors ;
IN: io.unix.select
-TUPLE: select-mx read-fdset write-fdset ;
+TUPLE: select-mx < mx read-fdset write-fdset ;
! Factor's bit-arrays are an array of bytes, OS X expects
! FD_SET to be an array of cells, so we have to account for
little-endian? [ BIN: 11000 bitxor ] unless ; inline
: <select-mx> ( -- mx )
- select-mx construct-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>write-fdset ;
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ;
[ handle-fd ] 2curry assoc-each ;
: init-fdset ( tasks fdset -- )
- ! dup clear-bits
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
: read-fdset/tasks
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
: init-fdsets ( mx -- nfds read write except )
- [ num-fds ] keep
- [ read-fdset/tasks tuck init-fdset ] keep
- write-fdset/tasks tuck init-fdset
+ [ num-fds ]
+ [ read-fdset/tasks tuck init-fdset ]
+ [ write-fdset/tasks tuck init-fdset ] tri
f ;
M: select-mx wait-for-events ( ms mx -- )
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files io.files.private system ;
+combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
-TUPLE: connect-task ;
+TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
- connect-task <output-task> ;
+ connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix (client) ( addrspec -- client-in client-out )
+M: unix ((client)) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
-TUPLE: accept-task ;
+TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
- accept-task <input-task> ;
+ accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
dup port-handle swap server-port-addr sockaddr-type
M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
- dup check-server-port
- dup wait-to-accept
- dup pending-error
- dup server-port-client-addr
- swap server-port-client ;
+ check-server-port
+ [ wait-to-accept ]
+ [ pending-error ]
+ [ [ client-addr>> ] [ client>> ] bi ] tri ;
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
rot head
] if ;
-TUPLE: receive-task ;
+TUPLE: receive-task < input-task ;
: <receive-task> ( stream continuation -- task )
- receive-task <input-task> ;
+ receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
[ <receive-task> add-io-task ] with-port-continuation drop ;
M: unix receive ( datagram -- packet addrspec )
- dup check-datagram-port
- dup wait-receive
- dup pending-error
- dup datagram-port-packet
- swap datagram-port-packet-addr ;
+ check-datagram-port
+ [ wait-receive ]
+ [ pending-error ]
+ [ [ packet>> ] [ packet-addr>> ] bi ] tri ;
: do-send ( socket data sockaddr len -- n )
>r >r dup length 0 r> r> sendto ;
-TUPLE: send-task packet sockaddr len ;
+TUPLE: send-task < output-task packet sockaddr len ;
: <send-task> ( packet sockaddr len stream continuation -- task )
- send-task <output-task> [
+ send-task <io-task> [
{
set-send-task-packet
set-send-task-sockaddr
2drop 2drop ;
M: unix send ( packet addrspec datagram -- )
- 3dup check-datagram-send
+ check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
socket-server <local>
ascii <server> [
- accept [
+ accept drop [
"Hello world" print flush
readln "XYZ" = "FOO" "BAR" ? print flush
] with-stream
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences words ;
+system vocabs.loader sequences words init ;
"io.unix." os word-name append require
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
--- /dev/null
+IN: io.windows.launcher.tests\r
+USING: tools.test io.windows.launcher ;\r
+\r
+[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
+\r
+[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations destructors io
+USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
-io.streams.duplex windows.types math windows.kernel32 windows
-namespaces io.launcher kernel sequences windows.errors assocs
+io.streams.duplex windows.types math windows.kernel32
+namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files ;
+io.backend accessors concurrency.flags io.files assocs
+io.files.private windows destructors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj )
- CreateProcess-args construct-empty
+ CreateProcess-args new
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
- 0 >>dwCreateFlags
- current-directory get (normalize-path) >>lpCurrentDirectory ;
+ 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
{
lpProcessInformation>>
} get-slots CreateProcess win32-error=0/f ;
+: count-trailing-backslashes ( str n -- str n )
+ >r "\\" ?tail [
+ r> 1+ count-trailing-backslashes
+ ] [
+ r>
+ ] if ;
+
+: fix-trailing-backslashes ( str -- str' )
+ 0 count-trailing-backslashes
+ 2 * CHAR: \\ <repetition> append ;
+
: escape-argument ( str -- newstr )
- CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
+ CHAR: \s over member? [
+ "\"" swap fix-trailing-backslashes "\"" 3append
+ ] when ;
: join-arguments ( args -- cmd-line )
[ escape-argument ] map " " join ;
M: windows run-process* ( process -- handle )
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
tuck fill-redirection
dup call-CreateProcess
over process-handle dispose-process
notify-exit ;
-: wait-for-processes ( processes -- ? )
- keys dup
+M: windows wait-for-processes ( -- ? )
+ processes get keys dup
[ process-handle PROCESS_INFORMATION-hProcess ] map
dup length swap >c-void*-array 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
-
-SYMBOL: wait-flag
-
-: wait-loop ( -- )
- processes get dup assoc-empty?
- [ drop wait-flag get-global lower-flag ]
- [ wait-for-processes [ 100 sleep ] when ] if ;
-
-: start-wait-thread ( -- )
- <flag> wait-flag set-global
- [ wait-loop t ] "Process wait" spawn-server drop ;
-
-M: windows register-process
- drop wait-flag get-global raise-flag ;
-
-[ start-wait-thread ] "io.windows.launcher" add-init-hook
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
- f \ mapped-file construct-boa
+ f \ mapped-file boa
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib system ;
+combinators.lib system accessors ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
- { [ dup eof? ] [ drop t swap set-port-eof? f ] }
- { [ t ] [ (win32-error-string) throw ] }
+ { [ dup eof? ] [ drop t >>eof drop f ] }
+ [ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
- dup port-handle win32-file-handle rot 0 <uint>
+ dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
] [
dup eof? [
drop lookup-callback
- dup io-callback-port t swap set-port-eof?
+ dup port>> t >>eof drop
] [
(win32-error-string) swap lookup-callback
- [ io-callback-port set-port-error ] keep
- ] if io-callback-thread resume f
+ [ port>> set-port-error ] keep
+ ] if thread>> resume f
] if
] [
lookup-callback
handle-overlapped [ 0 drain-overlapped ] unless ;
M: winnt cancel-io
- port-handle win32-file-handle CancelIo drop ;
+ handle>> handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )
drain-overlapped ;
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
-[ ] [ "" resource-path cd ] unit-test
-
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces
-io.files.private ;
+io.files.private accessors ;
IN: io.windows.nt.files
M: winnt cwd
{ [ dup length 2 = ] [ dup second CHAR: : = ] } && nip ] [
t
] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
ERROR: not-absolute-path ;
dup pending-error
tuck get-overlapped-result
dup pick update-file-ptr
- swap buffer-consume ;
+ swap buffer>> buffer-consume ;
: (flush-output) ( port -- )
dup make-FileArgs
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
[ finish-flush ] keep
- dup buffer-empty? [ drop ] [ (flush-output) ] if
+ dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
] [
2drop
] if ;
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
- dup buffer-empty? [ dup flush-output ] unless drop ;
+ dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- )
dup pending-error
tuck get-overlapped-result dup zero? [
- drop t swap set-port-eof?
+ drop t >>eof drop
] [
- dup pick n>buffer
+ dup pick buffer>> n>buffer
swap update-file-ptr
] if ;
IN: io.windows.launcher.nt.tests\r
USING: io.launcher tools.test calendar accessors\r
namespaces kernel system arrays io io.files io.encodings.ascii\r
-sequences parser assocs hashtables ;\r
+sequences parser assocs hashtables math ;\r
\r
[ ] [\r
<process>\r
\r
"HOME" swap at "XXX" =\r
] unit-test\r
+\r
+2 [\r
+ [ ] [\r
+ <process>\r
+ "cmd.exe /c dir" >>command\r
+ "dir.txt" temp-file >>stdout\r
+ try-process\r
+ ] unit-test\r
+\r
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test\r
+] times\r
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle accessors locals ;
+io.windows.launcher io.windows.nt.pipes io.backend io.files
+io.files.private combinators shuffle accessors locals ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? dup close-later ;
+ CreateFile dup invalid-handle? dup close-always ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: default-stdout ( args -- handle )
M: winnt (process-stream)
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
fill-stdout-pipe
--- /dev/null
+IN: io.windows.nt.monitors.tests\r
+USING: io.windows.nt.monitors tools.test ;\r
+\r
+\ fill-queue-thread must-infer\r
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types destructors io.windows
-io.windows.nt.backend kernel math windows windows.kernel32
-windows.types libc assocs alien namespaces continuations
-io.monitors io.monitors.private io.nonblocking io.buffers
-io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings system ;
+USING: alien alien.c-types libc destructors locals
+kernel math assocs namespaces continuations sequences hashtables
+sorting arrays combinators math.bitfields strings system
+accessors threads
+io.backend io.windows io.windows.nt.backend io.monitors
+io.nonblocking io.buffers io.files io.timeouts io
+windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
+ normalize-path
FILE_LIST_DIRECTORY
share-mode
f
dup add-completion
f <win32-file> ;
-TUPLE: win32-monitor path recursive? ;
+TUPLE: win32-monitor-port < input-port recursive ;
-: <win32-monitor> ( path recursive? port -- monitor )
- (monitor) {
- set-win32-monitor-path
- set-win32-monitor-recursive?
- set-delegate
- } win32-monitor construct ;
+TUPLE: win32-monitor < monitor port ;
-M: winnt <monitor> ( path recursive? -- monitor )
- [
- over open-directory win32-monitor <buffered-port>
- <win32-monitor>
- ] with-destructors ;
-
-: begin-reading-changes ( monitor -- overlapped )
- dup port-handle win32-file-handle
- over buffer-ptr
- pick buffer-size
- roll win32-monitor-recursive? 1 0 ?
+: begin-reading-changes ( port -- overlapped )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ptr>> ]
+ [ buffer>> size>> ]
+ [ recursive>> 1 0 ? ]
+ } cleave
FILE_NOTIFY_CHANGE_ALL
0 <uint>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
-: read-changes ( monitor -- bytes )
+: read-changes ( port -- bytes )
[
- [
- dup begin-reading-changes
- swap [ save-callback ] 2keep
- dup check-monitor ! we may have closed it...
- get-overlapped-result
- ] with-timeout
+ dup begin-reading-changes
+ swap [ save-callback ] 2keep
+ check-closed ! we may have closed it...
+ dup eof>> [ "EOF??" throw ] when
+ get-overlapped-result
] with-destructors ;
: parse-action ( action -- changed )
{
- { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] }
- { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] }
- { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] }
- { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] }
- { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] }
- { [ t ] [ +modify-file+ ] }
- } cond nip ;
+ { FILE_ACTION_ADDED [ +add-file+ ] }
+ { FILE_ACTION_REMOVED [ +remove-file+ ] }
+ { FILE_ACTION_MODIFIED [ +modify-file+ ] }
+ { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
+ { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
+ [ drop +modify-file+ ]
+ } case 1array ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
-: parse-file-notify ( buffer -- changed path )
- {
- FILE_NOTIFY_INFORMATION-FileName
- FILE_NOTIFY_INFORMATION-FileNameLength
- FILE_NOTIFY_INFORMATION-Action
- } get-slots parse-action 1array -rot memory>u16-string ;
-
-: (changed-files) ( buffer -- )
- dup parse-file-notify changed-file
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
- [ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
-
-M: win32-monitor fill-queue ( monitor -- )
- dup buffer-ptr over read-changes
- [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
- swap set-monitor-queue ;
+: parse-notify-record ( buffer -- path changed )
+ [
+ [ FILE_NOTIFY_INFORMATION-FileName ]
+ [ FILE_NOTIFY_INFORMATION-FileNameLength ]
+ bi memory>u16-string
+ ]
+ [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+
+: (file-notify-records) ( buffer -- buffer )
+ dup ,
+ dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
+ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ (file-notify-records)
+ ] unless ;
+
+: file-notify-records ( buffer -- seq )
+ [ (file-notify-records) drop ] { } make ;
+
+: parse-notify-records ( monitor buffer -- )
+ file-notify-records
+ [ parse-notify-record rot queue-change ] with each ;
+
+: fill-queue ( monitor -- )
+ dup port>> check-closed
+ [ buffer>> ptr>> ] [ read-changes zero? ] bi
+ [ 2dup parse-notify-records ] unless
+ 2drop ;
+
+: (fill-queue-thread) ( monitor -- )
+ dup fill-queue (fill-queue-thread) ;
+
+: fill-queue-thread ( monitor -- )
+ [ dup fill-queue (fill-queue-thread) ]
+ [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
+
+M:: winnt (monitor) ( path recursive? mailbox -- monitor )
+ [
+ path mailbox win32-monitor new-monitor
+ path open-directory \ win32-monitor-port <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ port>> dispose ;
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
- pipe construct-boa
+ pipe boa
] with-destructors ;
: close-pipe ( pipe -- )
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib system ;
+threads classes.tuple.lib system accessors ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
2dup save-callback
get-overlapped-result drop ;
-M: winnt (client) ( addrspec -- client-in client-out )
+M: winnt ((client)) ( addrspec -- client-in client-out )
[
- \ ConnectEx-args construct-empty
+ \ ConnectEx-args new
over make-sockaddr/size pick init-connect
over tcp-socket over set-ConnectEx-args-s*
dup ConnectEx-args-s* add-completion
M: winnt (accept) ( server -- addrspec handle )
[
[
- dup check-server-port
- \ AcceptEx-args construct-empty
+ check-server-port
+ \ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
[ accept-continuation ] keep
: init-WSARecvFrom ( datagram WSARecvFrom -- )
[ set-WSARecvFrom-args-port ] 2keep
[
- >r delegate port-handle delegate win32-file-handle r>
+ >r handle>> handle>> r>
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
M: winnt receive ( datagram -- packet addrspec )
[
- dup check-datagram-port
- \ WSARecvFrom-args construct-empty
+ check-datagram-port
+ \ WSARecvFrom-args new
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
[ WSARecvFrom-continuation ] keep
M: winnt send ( packet addrspec datagram -- )
[
- 3dup check-datagram-send
- \ WSASendTo-args construct-empty
+ check-datagram-send
+ \ WSASendTo-args new
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep
[ WSASendTo-continuation ] keep
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields system ;
+continuations math.bitfields system accessors ;
IN: io.windows
M: windows destruct-handle CloseHandle drop ;
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r
- share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
+ >r >r share-mode security-attributes-inherit r> r>
+ CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
] when drop ;
: open-append ( path -- handle length )
- [ dup file-info file-info-size ] [ drop 0 ] recover
+ [ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
- [ delegate ] keep
+ [ buffer>> ] keep
[
- buffer-length
+ buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
-TUPLE: win32-socket ;
+TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
- f <win32-file>
- \ win32-socket construct-delegate ;
+ f win32-file boa ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;
-
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io io.sockets kernel match namespaces
-sequences splitting strings continuations threads ascii
-io.encodings.utf8 ;
+USING: arrays calendar combinators channels concurrency.messaging fry io
+ io.encodings.8-bit io.sockets kernel math namespaces sequences
+ sequences.lib splitting strings threads
+ continuations classes.tuple ascii accessors ;
IN: irc
+! utils
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: spawn-server-linked ( quot name -- thread )
+ >r '[ , [ ] [ ] while ] r>
+ spawn-linked ;
+! ---
+
+! Default irc port
+: irc-port 6667 ;
+
+! Message used when the client isn't running anymore
+SINGLETON: irc-end
+
! "setup" objects
-TUPLE: profile server port nickname password default-channels ;
-C: <profile> profile
+TUPLE: irc-profile server port nickname password default-channels ;
+C: <irc-profile> irc-profile
-TUPLE: channel-profile name password auto-rejoin ;
-C: <channel-profile> channel-profile
+TUPLE: irc-channel-profile name password auto-rejoin ;
+C: <irc-channel-profile> irc-channel-profile
! "live" objects
-TUPLE: irc-client profile nick stream stream-process controller-process ;
-C: <irc-client> irc-client
-
TUPLE: nick name channels log ;
C: <nick> nick
-TUPLE: channel name topic members log attributes ;
-C: <channel> channel
+TUPLE: irc-client profile nick stream stream-channel controller-channel
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <channel> <channel> V{ } clone f irc-client boa ;
+
+USE: prettyprint
+TUPLE: irc-listener channel ;
+! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
+! tener la opción de dejar de correr un client??
+: <irc-listener> ( quot -- irc-listener )
+ <channel> irc-listener boa swap
+ [
+ [ channel>> '[ , from ] ]
+ [ '[ , curry f spawn drop ] ]
+ bi* compose "irc-listener" spawn-server-linked drop
+ ] [ drop ] 2bi ;
+
+! TUPLE: irc-channel name topic members log attributes ;
+! C: <irc-channel> irc-channel
! the delegate of all irc messages
-TUPLE: irc-message timestamp ;
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
C: <irc-message> irc-message
! "irc message" objects
-TUPLE: logged-in name text ;
+TUPLE: logged-in < irc-message name ;
C: <logged-in> logged-in
-TUPLE: ping name ;
+TUPLE: ping < irc-message ;
C: <ping> ping
-TUPLE: join name channel ;
-C: <join> join
+TUPLE: join_ < irc-message ;
+C: <join> join_
-TUPLE: part name channel text ;
+TUPLE: part < irc-message name channel ;
C: <part> part
-TUPLE: quit text ;
+TUPLE: quit ;
C: <quit> quit
-TUPLE: privmsg name text ;
+TUPLE: privmsg < irc-message name ;
C: <privmsg> privmsg
-TUPLE: kick channel er ee text ;
+TUPLE: kick < irc-message channel who ;
C: <kick> kick
-TUPLE: roomlist channel names ;
+TUPLE: roomlist < irc-message channel names ;
C: <roomlist> roomlist
-TUPLE: nick-in-use name ;
+TUPLE: nick-in-use < irc-message name ;
C: <nick-in-use> nick-in-use
-TUPLE: notice type text ;
+TUPLE: notice < irc-message type ;
C: <notice> notice
-TUPLE: mode name channel mode text ;
+TUPLE: mode < irc-message name channel mode ;
C: <mode> mode
-! TUPLE: members
-TUPLE: unhandled text ;
+TUPLE: unhandled < irc-message ;
C: <unhandled> unhandled
-! "control message" objects
-TUPLE: command sender ;
-TUPLE: service predicate quot enabled? ;
-TUPLE: chat-command from to text ;
-TUPLE: join-command channel password ;
-TUPLE: part-command channel text ;
-
SYMBOL: irc-client
-: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
-: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
+: irc-client> ( -- irc-client ) irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
: parse-name ( string -- string )
- trim-: "!" split first ;
-: irc-split ( string -- seq )
- 1 swap [ [ CHAR: : = ] find* ] keep
- swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
- " " split r> [ 1array append ] when* ;
+ remove-heading-: "!" split-at-first drop ;
+
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now <irc-message> ;
+
: me? ( name -- ? )
- irc-client get irc-client-nick nick-name = ;
+ irc-client> nick>> name>> = ;
: irc-write ( s -- )
irc-stream> stream-write ;
: irc-print ( s -- )
irc-stream> [ stream-print ] keep stream-flush ;
-: nick ( nick -- )
+! Irc commands
+
+: NICK ( nick -- )
"NICK " irc-write irc-print ;
-: login ( nick -- )
- dup nick
+: LOGIN ( nick -- )
+ dup NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
-: connect* ( server port -- )
- <inet> utf8 <client> irc-client get set-irc-client-stream ;
-
-: connect ( server -- ) 6667 connect* ;
+: CONNECT ( server port -- stream )
+ <inet> latin1 <client> ;
-: join ( channel password -- )
+: JOIN ( channel password -- )
"JOIN " irc-write
- [ >r " :" r> 3append ] when* irc-print ;
+ [ " :" swap 3append ] when* irc-print ;
-: part ( channel text -- )
- >r "PART " irc-write irc-write r>
+: PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
" :" irc-write irc-print ;
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
+: KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: SAY ( nick line -- )
+ PRIVMSG ;
-: quit ( text -- )
+: ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
+
+: QUIT ( text -- )
"QUIT :" irc-write irc-print ;
+: join-channel ( channel-profile -- )
+ [ name>> ] keep password>> JOIN ;
+: irc-connect ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> CONNECT ] keep
+ swap >>stream t >>is-running drop ;
+
GENERIC: handle-irc ( obj -- )
M: object handle-irc ( obj -- )
- "Unhandled irc object" print drop ;
+ drop ;
M: logged-in handle-irc ( obj -- )
- logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
-
- irc-client-profile profile-default-channels
- [
- [ channel-profile-name ] keep
- channel-profile-password join
- ] each ;
+ name>>
+ irc-client> [ nick>> swap >>name drop ] keep
+ profile>> default-channels>> [ join-channel ] each ;
M: ping handle-irc ( obj -- )
"PONG " irc-write
- ping-name irc-print ;
+ trailing>> irc-print ;
M: nick-in-use handle-irc ( obj -- )
- nick-in-use-name "_" append nick ;
-
-: delegate-timestamp ( obj -- obj )
- now <irc-message> over set-delegate ;
-
-MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
-SYMBOL: line
-: match-irc ( string -- )
- dup line set
- dup print flush
- irc-split
- {
- { { "PING" ?name }
- [ ?name <ping> ] }
- { { ?name "001" ?name2 ?text }
- [ ?name2 ?text <logged-in> ] }
- { { ?name "433" _ ?name2 "Nickname is already in use." }
- [ ?name2 <nick-in-use> ] }
-
- { { ?name "JOIN" ?channel }
- [ ?name ?channel <join> ] }
- { { ?name "PART" ?channel ?text }
- [ ?name ?channel ?text <part> ] }
- { { ?name "PRIVMSG" ?channel ?text }
- [ ?name ?channel ?text <privmsg> ] }
- { { ?name "QUIT" ?text }
- [ ?name ?text <quit> ] }
-
- { { "NOTICE" ?name ?text }
- [ ?name ?text <notice> ] }
- { { ?name "MODE" ?channel ?mode ?text }
- [ ?name ?channel ?mode ?text <mode> ] }
- { { ?name "KICK" ?channel ?name2 ?text }
- [ ?channel ?name ?name2 ?text <kick> ] }
-
- ! { { ?name "353" ?name2 _ ?channel ?text }
- ! [ ?text ?channel ?name2 make-member-list ] }
- { _ [ line get <unhandled> ] }
- } match-cond
- delegate-timestamp handle-irc flush ;
-
-: irc-loop ( -- )
- irc-stream> stream-readln
- [ match-irc irc-loop ] when* ;
-
+ name>> "_" append NICK ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join_ ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! Reader
+: handle-reader-message ( irc-client irc-message -- )
+ dup handle-irc swap stream-channel>> to ;
+
+: reader-loop ( irc-client -- )
+ dup stream>> stream-readln [
+ dup print parse-irc-line handle-reader-message
+ ] [
+ f >>is-running
+ dup stream>> dispose
+ irc-end over controller-channel>> to
+ stream-channel>> irc-end swap to
+ ] if* ;
+
+! Controller commands
+GENERIC: handle-command ( obj -- )
+
+M: object handle-command ( obj -- )
+ . ;
+
+TUPLE: send-message to text ;
+C: <send-message> send-message
+M: send-message handle-command ( obj -- )
+ dup to>> swap text>> SAY ;
+
+TUPLE: send-action to text ;
+C: <send-action> send-action
+M: send-action handle-command ( obj -- )
+ dup to>> swap text>> ACTION ;
+
+TUPLE: send-quit text ;
+C: <send-quit> send-quit
+M: send-quit handle-command ( obj -- )
+ text>> QUIT ;
+
+: irc-listen ( irc-client quot -- )
+ [ listeners>> ] [ <irc-listener> ] bi* swap push ;
+
+! Controller loop
+: controller-loop ( irc-client -- )
+ controller-channel>> from handle-command ;
+
+! Multiplexer
+: multiplex-message ( irc-client message -- )
+ swap listeners>> [ channel>> ] map
+ [ '[ , , to ] "message" spawn drop ] each-with ;
+
+: multiplexer-loop ( irc-client -- )
+ dup stream-channel>> from multiplex-message ;
+
+! process looping and starting
+: (spawn-irc-loop) ( irc-client quot name -- )
+ [ over >r curry r> '[ @ , is-running>> ] ] dip
+ spawn-server-linked drop ;
+
+: spawn-irc-loop ( irc-client quot name -- )
+ '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
+ f spawn drop ;
+
+: spawn-irc ( irc-client -- )
+ [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
+ [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
+ [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
+ tri ;
+
: do-irc ( irc-client -- )
- dup irc-client set
- dup irc-client-profile profile-server
- over irc-client-profile profile-port connect*
- dup irc-client-profile profile-nickname login
- [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
-
-: with-infinite-loop ( quot timeout -- quot timeout )
- "looping" print flush
- over [ drop ] recover dup sleep with-infinite-loop ;
-
-: start-irc ( irc-client -- )
- ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
- [ do-irc ] curry 3000 with-infinite-loop ;
-
-
-! For testing
-: make-factorbot
- "irc.freenode.org" 6667 "factorbot" f
- [
- "#concatenative-flood" f f <channel-profile> ,
- ] { } make <profile>
- f V{ } clone V{ } clone <nick>
- f f f <irc-client> ;
-
-: test-factorbot
- make-factorbot start-irc ;
-
+ irc-client [
+ irc-client>
+ [ irc-connect ]
+ [ profile>> nickname>> LOGIN ]
+ [ spawn-irc ]
+ tri
+ ] with-variable ;
\ No newline at end of file
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
- jamshred construct-boa ;
+ jamshred boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
- oint construct-boa ;
+ oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
TUPLE: player name tunnel nearest-segment ;
: <player> ( name -- player )
- f f player construct-boa
+ f f player boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
: turn-player ( player x-radians y-radians -- )
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
- <oint> >r segment construct-boa r> over set-delegate ;
+ <oint> >r segment boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
USING: arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle symbols ;
+splitting sorting shuffle symbols sets ;
IN: koszul
! Utilities
{ [ dup number? ] [ { } associate ] }
{ [ dup array? ] [ 1 swap associate ] }
{ [ dup hashtable? ] [ ] }
- { [ t ] [ 1array >alt ] }
+ [ 1array >alt ]
} cond ;
: canonicalize
! Printing elements
: num-alt. ( n -- str )
{
- { [ dup 1 = ] [ drop " + " ] }
- { [ dup -1 = ] [ drop " - " ] }
- { [ t ] [ number>string " + " prepend ] }
- } cond ;
+ { 1 [ " + " ] }
+ { -1 [ " - " ] }
+ [ number>string " + " prepend ]
+ } case ;
: (alt.) ( basis n -- str )
over empty? [
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons construct-boa
+ [ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
- over nil? [ nip ] [ >r cdr r> 1+ (llength) ] if ;
+ over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
- memoized-cons construct-boa ;
+ memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
- lazy-from-by-quot dup >r call r> lfrom-by ;
+ lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
- { [ t ] [ "Could not convert object to a list" throw ] }
+ [ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
] if ;
: lcomp ( list quot -- result )
- >r lcartesian-product* r> lmap ;
+ [ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
- >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;
+ [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ;
DEFER: lmerge
[
dup [ car ] curry -rot
[
- >r cdr r> cdr lmerge
+ [ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
- >r f f r> <lazy-io> [ swap set-lazy-io-cdr ] keep
+ [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
- [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
- 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
- dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
-
-: add-word-def ( word quot -- )
- dup callable? [
- def-hash get-global set-hash-vector
- ] [
- 2drop
- ] if ;
-
-: more-defs
- {
- { [ swap >r swap r> ] -rot }
- { [ swap swapd ] -rot }
- { [ >r swap r> swap ] rot }
- { [ swapd swap ] rot }
- { [ dup swap ] over }
- { [ dup -rot ] tuck }
- { [ >r swap r> ] swapd }
- { [ nip nip ] 2nip }
- { [ drop drop ] 2drop }
- { [ drop drop drop ] 3drop }
- { [ 0 = ] zero? }
- { [ pop drop ] pop* }
- { [ [ ] if ] when }
- } [ first2 swap add-word-def ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs
- {
- [ get ] [ t ] [ { } ] [ . ] [ drop f ]
- [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ <unimplemented-typeflag> throw ]
- [ "/>" write-html ]
- } ;
-
-H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
- drop empty? not
-] assoc-subset
-
-! Remove constants [ 1 ]
-[
- drop dup length 1 = swap first number? and not
-] assoc-subset
-
-! Remove set-alien-cell, etc.
-[
- drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
-] assoc-subset
-
-! Remove trivial defs
-[
- drop trivial-defs member? not
-] assoc-subset
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- dup first2 [ number? ] both?
- swap third \ shift = and not
- ] [ drop t ] if
-] assoc-subset
-
-! Remove [ n slot ]
-[
- drop dup length 2 = [
- first2 \ slot = swap number? and not
- ] [ drop t ] if
-] assoc-subset def-hash set-global
-
-: find-duplicates
- def-hash get-global [
- nip length 1 >
- ] assoc-subset ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
- drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ 2dup start ] [ 2dup member? ] } || 2nip ;
-
-M: callable lint ( quot -- seq )
- def-hash-keys get [
- swap subseq/member?
- ] with subset ;
-
-M: word lint ( word -- seq )
- word-def dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ word-vocabulary ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
- first2 >r word-path. r> [
- bl bl bl bl
- dup .
- "-----------------------------------" print
- def-hash get at [ bl bl bl bl word-path. ] each
- nl
- ] each nl nl ;
-
-: lint. ( alist -- )
- [ (lint.) ] each ;
-
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self)
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] subset ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get at
- [ first ] bi@ literalize = not
- ] assoc-subset ;
-
-M: sequence run-lint ( seq -- seq )
- [
- global [ dup . flush ] bind
- dup lint
- ] { } map>assoc
- trim-self
- [ second empty? not ] subset
- filter-symbols ;
-
-M: word run-lint ( word -- seq )
- 1array run-lint ;
-
-: lint-all ( -- seq )
- all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq )
- words run-lint dup lint. ;
-
-: lint-word ( word -- seq )
- 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
--- /dev/null
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays ;
+
+[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+
+[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
+
+: get-local-test-1 3 >r 1 get-local r> drop ;
+
+{ 0 1 } [ get-local-test-1 ] must-infer-as
+
+[ 3 ] [ get-local-test-1 ] unit-test
+
+: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+
+{ 0 1 } [ get-local-test-2 ] must-infer-as
+
+[ 4 ] [ get-local-test-2 ] unit-test
+
+: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+
+{ 0 2 } [ get-local-test-3 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
+
+: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+
+{ 0 2 } [ get-local-test-4 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
+
+[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
+
+: load-locals-test-1 1 2 2 load-locals r> r> ;
+
+{ 0 2 } [ load-locals-test-1 ] must-infer-as
+
+[ 1 2 ] [ load-locals-test-1 ] unit-test
--- /dev/null
+USING: math kernel slots.private inference.known-words
+inference.backend sequences effects words ;
+IN: locals.backend
+
+: load-locals ( n -- )
+ dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
+
+: get-local ( n -- value )
+ dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+
+: local-value 2 slot ; inline
+
+: set-local-value 2 set-slot ; inline
+
+: drop-locals ( n -- )
+ dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
+
+\ load-locals [
+ pop-literal nip
+ [ dup reverse <effect> infer-shuffle ]
+ [ infer->r ]
+ bi
+] "infer" set-word-prop
+
+\ get-local [
+ pop-literal nip
+ [ infer-r> ]
+ [ dup 0 prefix <effect> infer-shuffle ]
+ [ infer->r ]
+ tri
+] "infer" set-word-prop
+
+\ drop-locals [
+ pop-literal nip
+ [ infer-r> ]
+ [ { } <effect> infer-shuffle ] bi
+] "infer" set-word-prop
0 write-test-1 "q" set
+{ 1 1 } "q" get must-infer-as
+
[ 1 ] [ 1 "q" get call ] unit-test
[ 2 ] [ 1 "q" get call ] unit-test
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
-definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private effects generic
-compiler.units accessors ;
+definitions prettyprint hashtables prettyprint.sections sets
+sequences.private effects generic compiler.units accessors
+locals.backend ;
IN: locals
! Inspired by
C: <quote> quote
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! read-local
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ;
-: read-local ( obj args -- quot )
- local-index 1+
- dup [ r> ] <repetition> concat [ dup ] append
- swap [ swap >r ] <repetition> concat append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! localize
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: read-local-quot ( obj args -- quot )
+ local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
- >r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
+ >r "local-reader" word-prop r>
+ read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
- { [ over local? ] [ read-local ] }
- { [ over quote? ] [ >r quote-local r> read-local ] }
- { [ over local-word? ] [ read-local [ call ] append ] }
- { [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
+ { [ over local? ] [ read-local-quot ] }
+ { [ over quote? ] [ >r quote-local r> read-local-quot ] }
+ { [ over local-word? ] [ read-local-quot [ call ] append ] }
+ { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! point-free
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: special local quote local-word local-reader local-writer ;
-: load-local ( arg -- quot )
- local-reader? [ 1array >r ] [ >r ] ? ;
-
-: load-locals ( quot args -- quot )
- nip <reversed> [ load-local ] map concat ;
+: load-locals-quot ( args -- quot )
+ dup [ local-reader? ] contains? [
+ <reversed> [
+ local-reader? [ 1array >r ] [ >r ] ?
+ ] map concat
+ ] [
+ length [ load-locals ] curry >quotation
+ ] if ;
-: drop-locals ( args -- args quot )
- dup length [ r> drop ] <repetition> concat ;
+: drop-locals-quot ( args -- quot )
+ length [ drop-locals ] curry ;
: point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
- [ drop-locals >r >r peek r> localize r> append ]
- [ drop-locals nip swap peek suffix ]
+ [ dup drop-locals-quot >r >r peek r> localize r> append ]
+ [ dup drop-locals-quot nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
- [ load-locals ] [ point-free-body ] [ point-free-end ]
+ [ nip load-locals-quot ]
+ [ point-free-body ]
+ [ point-free-end ]
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! free-vars
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: lexical local local-reader local-writer local-word ;
-GENERIC: free-vars ( form -- vars )
+GENERIC: free-vars* ( form -- )
+
+: free-vars ( form -- vars )
+ [ free-vars* ] { } make prune ;
-: add-if-free ( vars object -- vars )
+: add-if-free ( object -- )
{
- { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
- { [ dup lexical? ] [ suffix ] }
- { [ dup quote? ] [ quote-local suffix ] }
- { [ t ] [ free-vars append ] }
+ { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+ { [ dup lexical? ] [ , ] }
+ { [ dup quote? ] [ local>> , ] }
+ { [ t ] [ free-vars* ] }
} cond ;
-M: object free-vars drop { } ;
+M: object free-vars* drop ;
-M: quotation free-vars { } [ add-if-free ] reduce ;
+M: quotation free-vars* [ add-if-free ] each ;
-M: lambda free-vars
- dup vars>> swap body>> free-vars seq-diff ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! lambda-rewrite
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: lambda free-vars*
+ [ vars>> ] [ body>> ] bi free-vars diff % ;
GENERIC: lambda-rewrite* ( obj -- )
M: lambda block-body body>> ;
M: lambda local-rewrite*
- dup vars>> swap body>>
- [ local-rewrite* \ call , ] [ ] make <lambda> , ;
+ [ vars>> ] [ body>> ] bi
+ [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: make-local ( name -- word )
"!" ?tail [
<local-reader>
parse-log-line {\r
{ [ dup malformed? ] [ malformed-line ] }\r
{ [ dup multiline? ] [ add-multiline ] }\r
- { [ t ] [ , ] }\r
+ [ , ]\r
} cond\r
] each\r
] { } make ;\r
rot [ empty? not ] subset {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
- { [ t ] [\r
+ [\r
[ first -rot f (write-message) ] 3keep\r
1 tail -rot [ t (write-message) ] 2curry each\r
- ] }\r
+ ]\r
} cond ;\r
\r
: (log-message) ( msg -- )\r
-Utility for defining compiler transforms, and short-circuiting boolean operators
+Utility for defining compiler transforms
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
[ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato construct-boa ;
+ dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
[ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
- { [ t ] [ ~abs ] }
+ [ ~abs ]
} cond ;
: power-of-2? ( n -- ? )
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
-hashtables ;
+hashtables sets ;
IN: math.miller-rabin
SYMBOL: a
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
- { [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
+ [ [ drop trials set t (miller-rabin) ] with-scope ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
--- /dev/null
+
+USING: kernel arrays math.vectors ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
- { [ t ]
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
: primes-between ( low high -- seq )
primes-upto
- >r 1- next-prime r>
+ [ 1- next-prime ] dip
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
- range construct-boa ;
+ range boa ;
M: range length ( seq -- n )
range-length ;
TUPLE: model-tester hit? ;
-: <model-tester> model-tester construct-empty ;
+: <model-tester> model-tester new ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
value connections dependencies ref locked? ;
: <model> ( value -- model )
- V{ } clone V{ } clone 0 f model construct-boa ;
+ V{ } clone V{ } clone 0 f model boa ;
M: model hashcode* drop model hashcode* ;
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test kernel math arrays sequences
-prettyprint strings classes hashtables assocs namespaces
-debugger continuations ;
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ -1 ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ 0 ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ 1 ] [
- { object object } { number sequence } classes<
-] unit-test
-
-[
- {
- { { object integer } [ 1 ] }
- { { object object } [ 2 ] }
- { { POSTPONE: f POSTPONE: f } [ 3 ] }
- }
-] [
- {
- { { integer } [ 1 ] }
- { { } [ 2 ] }
- { { f f } [ 3 ] }
- } congruify-methods
-] unit-test
-
-GENERIC: first-test
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-TUPLE: paper ; INSTANCE: paper thing
-TUPLE: scissors ; INSTANCE: scissors thing
-TUPLE: rock ; INSTANCE: rock thing
-
-GENERIC: beats?
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ t ] [ T{ paper } T{ scissors } play ] unit-test
-[ f ] [ T{ scissors } T{ paper } play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-GENERIC: legacy-test
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
-
-SYMBOL: some-var
-
-HOOK: hook-test some-var
-
-[ t ] [ \ hook-test hook-generic? ] unit-test
-
-METHOD: hook-test { array array } reverse ;
-METHOD: hook-test { array } class ;
-METHOD: hook-test { hashtable number } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io compiler.units kernel.private effects ;
+debugger io compiler.units kernel.private effects accessors
+hashtables sorting shuffle ;
IN: multi-methods
-GENERIC: generic-prologue ( combination -- quot )
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
-GENERIC: method-prologue ( combination -- quot )
+SYMBOL: args
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] subset
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] subset
+ [ keys [ hooks get push-new ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ >r
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get + r>
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ >r total get object <array> dup <enum> r> update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ >r canonicalize-specializer-0 r> ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ >r canonicalize-specializer-1 r> ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ >r canonicalize-specializer-2 r> ] assoc-map
+
+ args get hooks get length + total set
+
+ [ >r canonicalize-specializer-3 r> ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry subset empty?
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
- { [ t ] [ 0 ] }
+ [ 0 ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
: picker ( n -- quot )
{
{ 0 [ [ dup ] ] }
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ >r argument-count r> [ >r narray r> no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ >r multi-predicate r> ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
-: make-method-def ( quot classes generic -- quot )
+: make-generic ( generic -- quot )
[
- swap [ declare ] curry %
- "multi-combination" word-prop method-prologue %
- %
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
] [ ] make ;
-TUPLE: method word def classes generic loc ;
+: update-generic ( word -- )
+ dup make-generic define ;
+! Methods
PREDICATE: method-body < word
- "multi-method" word-prop >boolean ;
+ "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect
- "multi-method" word-prop method-generic stack-effect ;
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ drop t ;
+
+: method-word-name ( specializer generic -- string )
+ [ word-name % "-" % unparse % ] "" make ;
-: method-word-name ( classes generic -- string )
+: method-word-props ( specializer generic -- assoc )
[
- word-name %
- "-(" % [ "," % ] [ word-name % ] interleave ")" %
- ] "" make ;
-
-: <method-word> ( quot classes generic -- word )
- #! We xref here because the "multi-method" word-prop isn't
- #! set yet so crossref? yields f.
- [ make-method-def ] 2keep
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
method-word-name f <word>
- dup rot define
- dup xref ;
+ [ set-word-props ] keep ;
-: <method> ( quot classes generic -- method )
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "multi-method" set-word-prop ;
+: with-methods ( word quot -- )
+ over >r >r "multi-methods" word-prop
+ r> call r> update-generic ; inline
-TUPLE: no-method arguments generic ;
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
-: no-method ( argument-count generic -- * )
- >r narray r> \ no-method construct-boa throw ; inline
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
-: argument-count ( methods -- n )
- dup assoc-empty? [ drop 0 ] [
- keys [ length ] map supremum
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
] if ;
-: multi-dispatch-quot ( methods generic -- quot )
- >r [
- [
- >r multi-predicate r> method-word 1quotation
- ] assoc-map
- ] keep argument-count
- r> [ no-method ] 2curry
- swap reverse alist>quot ;
-
-: congruify-methods ( alist -- alist' )
- dup argument-count [
- swap >r object pad-left [ \ f or ] map r>
- ] curry assoc-map ;
-
-: sorted-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
nl
- "Generic word " write dup no-method-generic pprint
+ "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print
- dup no-method-arguments short.
+ dup arguments>> short.
nl
"Inputs have signature:" print
- dup no-method-arguments [ class ] map niceify-method .
+ dup arguments>> [ class ] map niceify-method .
nl
- "Defined methods in topological order: " print
- no-method-generic
- methods congruify-methods sorted-methods keys
- [ niceify-method ] map stack. ;
-
-TUPLE: standard-combination ;
-
-M: standard-combination method-prologue drop [ ] ;
-
-M: standard-combination generic-prologue drop [ ] ;
-
-: make-generic ( generic -- quot )
- dup "multi-combination" word-prop generic-prologue swap
- [ methods congruify-methods sorted-methods ] keep
- multi-dispatch-quot append ;
-
-TUPLE: hook-combination var ;
-
-M: hook-combination method-prologue
- drop [ drop ] ;
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
-M: hook-combination generic-prologue
- hook-combination-var [ get ] curry ;
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
-: update-generic ( word -- )
- dup make-generic define ;
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
-: define-generic ( word combination -- )
- over "multi-combination" word-prop over = [
- 2drop
+: define-generic ( word -- )
+ dup "multi-methods" word-prop [
+ drop
] [
- dupd "multi-combination" set-word-prop
- dup H{ } clone "multi-methods" set-word-prop
- update-generic
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
] if ;
-: define-standard-generic ( word -- )
- T{ standard-combination } define-generic ;
-
+! Syntax
: GENERIC:
- CREATE define-standard-generic ; parsing
-
-: define-hook-generic ( word var -- )
- hook-combination construct-boa define-generic ;
-
-: HOOK:
- CREATE scan-word define-hook-generic ; parsing
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
+ CREATE define-generic ; parsing
-: define-method ( quot classes generic -- )
- >r [ bootstrap-word ] map r>
- [ <method> ] 2keep
- [ set-at ] with-methods ;
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-: forget-method ( classes generic -- )
- [ delete-at ] with-methods ;
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
-: method>spec ( method -- spec )
- dup method-classes swap method-generic prefix ;
+: CREATE-METHOD
+ scan-word scan-object swap create-method-in ;
-: parse-method ( -- quot classes generic )
- parse-definition dup 2 tail over second rot first ;
+: (METHOD:) CREATE-METHOD parse-definition ;
-: METHOD:
- location
- >r parse-method [ define-method ] 2keep prefix r>
- remember-definition ; parsing
+: METHOD: (METHOD:) define ; parsing
! For compatibility
: M:
- scan-word 1array scan-word parse-definition
- -rot define-method ; parsing
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
QUALIFIED: syntax
-PREDICATE: generic < word
- "multi-combination" word-prop >boolean ;
-
-PREDICATE: standard-generic < word
- "multi-combination" word-prop standard-combination? ;
-
-PREDICATE: hook-generic < word
- "multi-combination" word-prop hook-combination? ;
+syntax:M: generic definer drop \ GENERIC: f ;
-syntax:M: standard-generic definer drop \ GENERIC: f ;
-
-syntax:M: standard-generic definition drop f ;
-
-syntax:M: hook-generic definer drop \ HOOK: f ;
-
-syntax:M: hook-generic definition drop f ;
-
-syntax:M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "multi-combination" word-prop
- hook-combination-var pprint-word stack-effect. ;
+syntax:M: generic definition drop f ;
PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
- dup unclip method [ method-loc ] [ second where ] ?if ;
+ dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where
- unclip method set-method-loc ;
+ unclip method set-where ;
syntax:M: method-spec definer
- drop \ METHOD: \ ; ;
+ unclip method definer ;
syntax:M: method-spec definition
- unclip method dup [ method-def ] when ;
+ unclip method definition ;
syntax:M: method-spec synopsis*
- dup definer.
- unclip pprint* pprint* ;
+ unclip method synopsis* ;
syntax:M: method-spec forget*
- unclip forget-method ;
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ } ;
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ V{ cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+\ GENERIC: must-infer
+\ create-method-in must-infer
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors ;
+
+GENERIC: first-test
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats?
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+IN: multi-methods.tests
+USING: kernel multi-methods tools.test math arrays sequences ;
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+ { object object } { number sequence } classes<
+] unit-test
-USING: kernel sequences assocs qualified ;
+USING: kernel sequences assocs qualified circular ;
+
+USING: math multi-methods ;
QUALIFIED: sequences
+QUALIFIED: assocs
+QUALIFIED: circular
IN: newfx
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Now, we can see a new world coming into view.
! A world in which there is the very real prospect of a new world order.
!
! - George Herbert Walker Bush
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at ( col key -- val )
+GENERIC: of ( key col -- val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: grab ( col key -- col val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is ( col key val -- col )
+GENERIC: as ( col val key -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is-of ( key val col -- col )
+GENERIC: as-of ( val key col -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: mutate-at ( col key val -- )
+GENERIC: mutate-as ( col val key -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at-mutate ( key val col -- )
+GENERIC: as-mutate ( val key col -- )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! sequence
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-at ( seq i -- val ) swap nth ;
-: nth-of ( i seq -- val ) nth ;
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is ( seq i val -- seq ) swap pick set-nth ;
-: is-nth ( seq val i -- seq ) pick set-nth ;
+METHOD: grab { sequence number } dupd swap nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-nth ( seq i val -- ) swap rot set-nth ;
-: mutate-at-nth ( seq val i -- ) rot set-nth ;
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-nth-of ( i val seq -- ) swapd set-nth ;
-: mutate-at-nth-of ( val i seq -- ) set-nth ;
+METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
+METHOD: as-of { object number sequence } dup >r set-nth r> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: at-key ( tbl key -- val ) swap at ;
-: key-of ( key tbl -- val ) at ;
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: key-is ( tbl key val -- tbl ) swap pick set-at ;
-: is-key ( tbl val key -- tbl ) pick set-at ;
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-key ( tbl key val -- ) swap rot set-at ;
-: mutate-at-key ( tbl val key -- ) rot set-at ;
-: mutate-key-of ( key val tbl -- ) swapd set-at ;
-: mutate-at-key-of ( val key tbl -- ) set-at ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: push ( seq obj -- seq ) over sequences:push ;
-: push-on ( obj seq -- seq ) tuck sequences:push ;
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { assoc object } dupd swap assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { assoc object object } swap pick set-at ;
+METHOD: as { assoc object object } pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
+METHOD: as-of { object object assoc } dup >r set-at r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+: pushed ( seq obj -- ) swap sequences:push ;
+: pushed-on ( obj seq -- ) sequences:push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: delete ( seq elt -- seq ) over sequences:delete ;
+: delete-from ( elt seq -- seq ) tuck sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deleted ( seq elt -- ) swap sequences:delete ;
+: deleted-from ( elt seq -- ) sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove ( seq obj -- seq ) swap sequences:remove ;
+: remove-from ( obj seq -- seq ) sequences:remove ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subset-of ( quot seq -- seq ) swap subset ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-over ( quot seq -- seq ) swap map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel alien alien.syntax combinators alien.c-types\r
- strings sequences namespaces words math threads ;\r
-IN: odbc\r
-\r
-"odbc" "odbc32.dll" "stdcall" add-library\r
-\r
-LIBRARY: odbc\r
-\r
-TYPEDEF: void* usb_dev_handle*\r
-TYPEDEF: short SQLRETURN\r
-TYPEDEF: short SQLSMALLINT\r
-TYPEDEF: short* SQLSMALLINT*\r
-TYPEDEF: ushort SQLUSMALLINT\r
-TYPEDEF: uint* SQLUINTEGER*\r
-TYPEDEF: int SQLINTEGER\r
-TYPEDEF: char SQLCHAR\r
-TYPEDEF: char* SQLCHAR*\r
-TYPEDEF: void* SQLHANDLE\r
-TYPEDEF: void* SQLHANDLE*\r
-TYPEDEF: void* SQLHENV\r
-TYPEDEF: void* SQLHDBC\r
-TYPEDEF: void* SQLHSTMT\r
-TYPEDEF: void* SQLHWND\r
-TYPEDEF: void* SQLPOINTER\r
-\r
-: SQL-HANDLE-ENV ( -- number ) 1 ; inline\r
-: SQL-HANDLE-DBC ( -- number ) 2 ; inline\r
-: SQL-HANDLE-STMT ( -- number ) 3 ; inline\r
-: SQL-HANDLE-DESC ( -- number ) 4 ; inline\r
-\r
-: SQL-NULL-HANDLE ( -- alien ) f ; inline\r
-\r
-: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline\r
-\r
-: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline\r
-: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline\r
-\r
-: SQL-SUCCESS ( -- number ) 0 ; inline\r
-: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline\r
-: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline\r
-\r
-: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline\r
-: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline\r
-\r
-: SQL-C-DEFAULT ( -- number ) 99 ; inline\r
-\r
-SYMBOL: SQL-CHAR\r
-SYMBOL: SQL-VARCHAR\r
-SYMBOL: SQL-LONGVARCHAR\r
-SYMBOL: SQL-WCHAR\r
-SYMBOL: SQL-WCHARVAR\r
-SYMBOL: SQL-WLONGCHARVAR\r
-SYMBOL: SQL-DECIMAL\r
-SYMBOL: SQL-SMALLINT\r
-SYMBOL: SQL-NUMERIC\r
-SYMBOL: SQL-INTEGER\r
-SYMBOL: SQL-REAL\r
-SYMBOL: SQL-FLOAT\r
-SYMBOL: SQL-DOUBLE\r
-SYMBOL: SQL-BIT\r
-SYMBOL: SQL-TINYINT\r
-SYMBOL: SQL-BIGINT\r
-SYMBOL: SQL-BINARY\r
-SYMBOL: SQL-VARBINARY\r
-SYMBOL: SQL-LONGVARBINARY\r
-SYMBOL: SQL-TYPE-DATE\r
-SYMBOL: SQL-TYPE-TIME\r
-SYMBOL: SQL-TYPE-TIMESTAMP\r
-SYMBOL: SQL-TYPE-UTCDATETIME\r
-SYMBOL: SQL-TYPE-UTCTIME\r
-SYMBOL: SQL-INTERVAL-MONTH\r
-SYMBOL: SQL-INTERVAL-YEAR\r
-SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH\r
-SYMBOL: SQL-INTERVAL-DAY\r
-SYMBOL: SQL-INTERVAL-HOUR\r
-SYMBOL: SQL-INTERVAL-MINUTE\r
-SYMBOL: SQL-INTERVAL-SECOND\r
-SYMBOL: SQL-INTERVAL-DAY-TO-HOUR\r
-SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-DAY-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND\r
-SYMBOL: SQL-GUID\r
-SYMBOL: SQL-TYPE-UNKNOWN\r
-\r
-: convert-sql-type ( number -- symbol )\r
- {\r
- { [ dup 1 = ] [ drop SQL-CHAR ] }\r
- { [ dup 12 = ] [ drop SQL-VARCHAR ] }\r
- { [ dup -1 = ] [ drop SQL-LONGVARCHAR ] }\r
- { [ dup -8 = ] [ drop SQL-WCHAR ] }\r
- { [ dup -9 = ] [ drop SQL-WCHARVAR ] }\r
- { [ dup -10 = ] [ drop SQL-WLONGCHARVAR ] }\r
- { [ dup 3 = ] [ drop SQL-DECIMAL ] }\r
- { [ dup 5 = ] [ drop SQL-SMALLINT ] }\r
- { [ dup 2 = ] [ drop SQL-NUMERIC ] }\r
- { [ dup 4 = ] [ drop SQL-INTEGER ] }\r
- { [ dup 7 = ] [ drop SQL-REAL ] }\r
- { [ dup 6 = ] [ drop SQL-FLOAT ] }\r
- { [ dup 8 = ] [ drop SQL-DOUBLE ] }\r
- { [ dup -7 = ] [ drop SQL-BIT ] }\r
- { [ dup -6 = ] [ drop SQL-TINYINT ] }\r
- { [ dup -5 = ] [ drop SQL-BIGINT ] }\r
- { [ dup -2 = ] [ drop SQL-BINARY ] }\r
- { [ dup -3 = ] [ drop SQL-VARBINARY ] } \r
- { [ dup -4 = ] [ drop SQL-LONGVARBINARY ] }\r
- { [ dup 91 = ] [ drop SQL-TYPE-DATE ] }\r
- { [ dup 92 = ] [ drop SQL-TYPE-TIME ] }\r
- { [ dup 93 = ] [ drop SQL-TYPE-TIMESTAMP ] }\r
- { [ t ] [ drop SQL-TYPE-UNKNOWN ] }\r
- } cond ;\r
-\r
-: succeeded? ( n -- bool )\r
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)\r
- {\r
- { [ dup SQL-SUCCESS = ] [ drop t ] }\r
- { [ dup SQL-SUCCESS-WITH-INFO = ] [ drop t ] }\r
- { [ t ] [ drop f ] }\r
- } cond ; \r
-\r
-FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;\r
-FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;\r
-FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ; \r
-FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;\r
-FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;\r
-FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;\r
-FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;\r
-FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;\r
-FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;\r
-\r
-: alloc-handle ( type parent -- handle )\r
- f <void*> [ SQLAllocHandle ] keep swap succeeded? [\r
- *void*\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: alloc-env-handle ( -- handle )\r
- SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;\r
-\r
-: alloc-dbc-handle ( env -- handle )\r
- SQL-HANDLE-DBC swap alloc-handle ;\r
-\r
-: alloc-stmt-handle ( dbc -- handle )\r
- SQL-HANDLE-STMT swap alloc-handle ;\r
-\r
-: temp-string ( length -- byte-array length )\r
- [ CHAR: \space <string> string>char-alien ] keep ;\r
-\r
-: odbc-init ( -- env )\r
- alloc-env-handle\r
- [ \r
- SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr \r
- succeeded? [ "odbc-init failed" throw ] unless\r
- ] keep ;\r
-\r
-: odbc-connect ( env dsn -- dbc )\r
- >r alloc-dbc-handle dup r> \r
- f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT \r
- SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;\r
-\r
-: odbc-disconnect ( dbc -- )\r
- SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ; \r
-\r
-: odbc-prepare ( dbc string -- statement )\r
- >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;\r
-\r
-: odbc-free-statement ( statement -- )\r
- SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;\r
-\r
-: odbc-execute ( statement -- )\r
- SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;\r
-\r
-: odbc-next-row ( statement -- bool )\r
- SQLFetch succeeded? ;\r
-\r
-: odbc-number-of-columns ( statement -- number )\r
- 0 <short> [ SQLNumResultCols succeeded? ] keep swap [\r
- *short\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-TUPLE: column nullable digits size type name number ;\r
-\r
-C: <column> column\r
-\r
-: odbc-describe-column ( statement n -- column )\r
- dup >r\r
- 1024 CHAR: \space <string> string>char-alien dup >r\r
- 1024 \r
- 0 <short>\r
- 0 <short> dup >r\r
- 0 <uint> dup >r\r
- 0 <short> dup >r\r
- 0 <short> dup >r\r
- SQLDescribeCol succeeded? [\r
- r> *short \r
- r> *short \r
- r> *uint \r
- r> *short convert-sql-type \r
- r> alien>char-string \r
- r> <column> \r
- ] [\r
- r> drop r> drop r> drop r> drop r> drop r> drop\r
- "odbc-describe-column failed" throw\r
- ] if ;\r
-\r
-: dereference-type-pointer ( byte-array column -- object )\r
- column-type {\r
- { [ dup SQL-CHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-VARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-LONGVARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WLONGCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-SMALLINT = ] [ drop *short ] }\r
- { [ dup SQL-INTEGER = ] [ drop *long ] }\r
- { [ dup SQL-REAL = ] [ drop *float ] }\r
- { [ dup SQL-FLOAT = ] [ drop *double ] }\r
- { [ dup SQL-DOUBLE = ] [ drop *double ] }\r
- { [ dup SQL-TINYINT = ] [ drop *char ] }\r
- { [ dup SQL-BIGINT = ] [ drop *longlong ] }\r
- { [ t ] [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] } \r
- } cond ;\r
-\r
-TUPLE: field value column ;\r
-\r
-C: <field> field\r
-\r
-: odbc-get-field ( statement column -- field )\r
- dup column? [ dupd odbc-describe-column ] unless dup >r column-number\r
- SQL-C-DEFAULT\r
- 8192 CHAR: \space <string> string>char-alien dup >r\r
- 8192 \r
- f SQLGetData succeeded? [\r
- r> r> [ dereference-type-pointer ] keep <field>\r
- ] [\r
- r> drop r> [ \r
- "SQLGetData Failed for Column: " % \r
- dup column-name % \r
- " of type: " % dup column-type word-name %\r
- ] "" make swap <field>\r
- ] if ;\r
-\r
-: odbc-get-row-fields ( statement -- seq )\r
- [\r
- dup odbc-number-of-columns [\r
- 1+ odbc-get-field field-value ,\r
- ] with each \r
- ] { } make ;\r
-\r
-: (odbc-get-all-rows) ( statement -- )\r
- dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ; \r
- \r
-: odbc-get-all-rows ( statement -- seq )\r
- [ (odbc-get-all-rows) ] { } make ;\r
- \r
-: odbc-query ( string dsn -- result )\r
- odbc-init swap odbc-connect [\r
- swap odbc-prepare\r
- dup odbc-execute\r
- dup odbc-get-all-rows\r
- swap odbc-free-statement\r
- ] keep odbc-disconnect ;
\ No newline at end of file
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.syntax combinators alien.c-types
+ strings sequences namespaces words math threads ;
+IN: odbc
+
+"odbc" "odbc32.dll" "stdcall" add-library
+
+LIBRARY: odbc
+
+TYPEDEF: void* usb_dev_handle*
+TYPEDEF: short SQLRETURN
+TYPEDEF: short SQLSMALLINT
+TYPEDEF: short* SQLSMALLINT*
+TYPEDEF: ushort SQLUSMALLINT
+TYPEDEF: uint* SQLUINTEGER*
+TYPEDEF: int SQLINTEGER
+TYPEDEF: char SQLCHAR
+TYPEDEF: char* SQLCHAR*
+TYPEDEF: void* SQLHANDLE
+TYPEDEF: void* SQLHANDLE*
+TYPEDEF: void* SQLHENV
+TYPEDEF: void* SQLHDBC
+TYPEDEF: void* SQLHSTMT
+TYPEDEF: void* SQLHWND
+TYPEDEF: void* SQLPOINTER
+
+: SQL-HANDLE-ENV ( -- number ) 1 ; inline
+: SQL-HANDLE-DBC ( -- number ) 2 ; inline
+: SQL-HANDLE-STMT ( -- number ) 3 ; inline
+: SQL-HANDLE-DESC ( -- number ) 4 ; inline
+
+: SQL-NULL-HANDLE ( -- alien ) f ; inline
+
+: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
+
+: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
+: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
+
+: SQL-SUCCESS ( -- number ) 0 ; inline
+: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
+: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
+
+: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
+: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
+
+: SQL-C-DEFAULT ( -- number ) 99 ; inline
+
+SYMBOL: SQL-CHAR
+SYMBOL: SQL-VARCHAR
+SYMBOL: SQL-LONGVARCHAR
+SYMBOL: SQL-WCHAR
+SYMBOL: SQL-WCHARVAR
+SYMBOL: SQL-WLONGCHARVAR
+SYMBOL: SQL-DECIMAL
+SYMBOL: SQL-SMALLINT
+SYMBOL: SQL-NUMERIC
+SYMBOL: SQL-INTEGER
+SYMBOL: SQL-REAL
+SYMBOL: SQL-FLOAT
+SYMBOL: SQL-DOUBLE
+SYMBOL: SQL-BIT
+SYMBOL: SQL-TINYINT
+SYMBOL: SQL-BIGINT
+SYMBOL: SQL-BINARY
+SYMBOL: SQL-VARBINARY
+SYMBOL: SQL-LONGVARBINARY
+SYMBOL: SQL-TYPE-DATE
+SYMBOL: SQL-TYPE-TIME
+SYMBOL: SQL-TYPE-TIMESTAMP
+SYMBOL: SQL-TYPE-UTCDATETIME
+SYMBOL: SQL-TYPE-UTCTIME
+SYMBOL: SQL-INTERVAL-MONTH
+SYMBOL: SQL-INTERVAL-YEAR
+SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
+SYMBOL: SQL-INTERVAL-DAY
+SYMBOL: SQL-INTERVAL-HOUR
+SYMBOL: SQL-INTERVAL-MINUTE
+SYMBOL: SQL-INTERVAL-SECOND
+SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
+SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
+SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
+SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
+SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
+SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
+SYMBOL: SQL-GUID
+SYMBOL: SQL-TYPE-UNKNOWN
+
+: convert-sql-type ( number -- symbol )
+ {
+ { 1 [ SQL-CHAR ] }
+ { 12 [ SQL-VARCHAR ] }
+ { -1 [ SQL-LONGVARCHAR ] }
+ { -8 [ SQL-WCHAR ] }
+ { -9 [ SQL-WCHARVAR ] }
+ { -10 [ SQL-WLONGCHARVAR ] }
+ { 3 [ SQL-DECIMAL ] }
+ { 5 [ SQL-SMALLINT ] }
+ { 2 [ SQL-NUMERIC ] }
+ { 4 [ SQL-INTEGER ] }
+ { 7 [ SQL-REAL ] }
+ { 6 [ SQL-FLOAT ] }
+ { 8 [ SQL-DOUBLE ] }
+ { -7 [ SQL-BIT ] }
+ { -6 [ SQL-TINYINT ] }
+ { -5 [ SQL-BIGINT ] }
+ { -2 [ SQL-BINARY ] }
+ { -3 [ SQL-VARBINARY ] }
+ { -4 [ SQL-LONGVARBINARY ] }
+ { 91 [ SQL-TYPE-DATE ] }
+ { 92 [ SQL-TYPE-TIME ] }
+ { 93 [ SQL-TYPE-TIMESTAMP ] }
+ [ drop SQL-TYPE-UNKNOWN ]
+ } case ;
+
+: succeeded? ( n -- bool )
+ #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ {
+ { SQL-SUCCESS [ t ] }
+ { SQL-SUCCESS-WITH-INFO [ t ] }
+ [ drop f ]
+ } case ;
+
+FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
+FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
+FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
+FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
+FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
+FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
+FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
+FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
+FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
+
+: alloc-handle ( type parent -- handle )
+ f <void*> [ SQLAllocHandle ] keep swap succeeded? [
+ *void*
+ ] [
+ drop f
+ ] if ;
+
+: alloc-env-handle ( -- handle )
+ SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
+
+: alloc-dbc-handle ( env -- handle )
+ SQL-HANDLE-DBC swap alloc-handle ;
+
+: alloc-stmt-handle ( dbc -- handle )
+ SQL-HANDLE-STMT swap alloc-handle ;
+
+: temp-string ( length -- byte-array length )
+ [ CHAR: \space <string> string>char-alien ] keep ;
+
+: odbc-init ( -- env )
+ alloc-env-handle
+ [
+ SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
+ succeeded? [ "odbc-init failed" throw ] unless
+ ] keep ;
+
+: odbc-connect ( env dsn -- dbc )
+ >r alloc-dbc-handle dup r>
+ f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
+ SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
+
+: odbc-disconnect ( dbc -- )
+ SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
+
+: odbc-prepare ( dbc string -- statement )
+ >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
+
+: odbc-free-statement ( statement -- )
+ SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
+
+: odbc-execute ( statement -- )
+ SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
+
+: odbc-next-row ( statement -- bool )
+ SQLFetch succeeded? ;
+
+: odbc-number-of-columns ( statement -- number )
+ 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
+ *short
+ ] [
+ drop f
+ ] if ;
+
+TUPLE: column nullable digits size type name number ;
+
+C: <column> column
+
+: odbc-describe-column ( statement n -- column )
+ dup >r
+ 1024 CHAR: \space <string> string>char-alien dup >r
+ 1024
+ 0 <short>
+ 0 <short> dup >r
+ 0 <uint> dup >r
+ 0 <short> dup >r
+ 0 <short> dup >r
+ SQLDescribeCol succeeded? [
+ r> *short
+ r> *short
+ r> *uint
+ r> *short convert-sql-type
+ r> alien>char-string
+ r> <column>
+ ] [
+ r> drop r> drop r> drop r> drop r> drop r> drop
+ "odbc-describe-column failed" throw
+ ] if ;
+
+: dereference-type-pointer ( byte-array column -- object )
+ column-type {
+ { SQL-CHAR [ alien>char-string ] }
+ { SQL-VARCHAR [ alien>char-string ] }
+ { SQL-LONGVARCHAR [ alien>char-string ] }
+ { SQL-WCHAR [ alien>char-string ] }
+ { SQL-WCHARVAR [ alien>char-string ] }
+ { SQL-WLONGCHARVAR [ alien>char-string ] }
+ { SQL-SMALLINT [ *short ] }
+ { SQL-INTEGER [ *long ] }
+ { SQL-REAL [ *float ] }
+ { SQL-FLOAT [ *double ] }
+ { SQL-DOUBLE [ *double ] }
+ { SQL-TINYINT [ *char ] }
+ { SQL-BIGINT [ *longlong ] }
+ [ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
+ } case ;
+
+TUPLE: field value column ;
+
+C: <field> field
+
+: odbc-get-field ( statement column -- field )
+ dup column? [ dupd odbc-describe-column ] unless dup >r column-number
+ SQL-C-DEFAULT
+ 8192 CHAR: \space <string> string>char-alien dup >r
+ 8192
+ f SQLGetData succeeded? [
+ r> r> [ dereference-type-pointer ] keep <field>
+ ] [
+ r> drop r> [
+ "SQLGetData Failed for Column: " %
+ dup column-name %
+ " of type: " % dup column-type word-name %
+ ] "" make swap <field>
+ ] if ;
+
+: odbc-get-row-fields ( statement -- seq )
+ [
+ dup odbc-number-of-columns [
+ 1+ odbc-get-field field-value ,
+ ] with each
+ ] { } make ;
+
+: (odbc-get-all-rows) ( statement -- )
+ dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
+
+: odbc-get-all-rows ( statement -- seq )
+ [ (odbc-get-all-rows) ] { } make ;
+
+: odbc-query ( string dsn -- result )
+ odbc-init swap odbc-connect [
+ swap odbc-prepare
+ dup odbc-execute
+ dup odbc-get-all-rows
+ swap odbc-free-statement
+ ] keep odbc-disconnect ;
num-audio-buffers-processed {\r
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }\r
- { [ t ] [ fill-processed-audio-buffer t ] }\r
+ [ fill-processed-audio-buffer t ]\r
} cond ;\r
\r
: start-audio ( player -- player bool )\r
decode-packet {\r
{ [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
{ [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
- { [ t ] [ handle-initial-unknown-header ] }\r
+ [ handle-initial-unknown-header ]\r
} cond t\r
] [\r
f\r
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting opengl.gl
-continuations math.parser math arrays ;
+continuations math.parser math arrays sets ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
: has-gl-extensions? ( extensions -- ? )
gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions swap seq-diff
+ gl-extensions swap diff
"Required OpenGL extensions not supported:\n" %
[ " " % % "\n" % ] each ;
: require-gl-extensions ( extensions -- )
USING: alien alien.syntax combinators kernel parser sequences
-system words namespaces hashtables init math arrays assocs
-sequences.lib continuations ;
+system words namespaces hashtables init math arrays assocs
+continuations ;
+IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
<< {
{ [ os windows? ] [ "opengl.gl.windows" ] }
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
- { [ t ] [ unknown-gl-platform ] }
+ [ unknown-gl-platform ]
} cond use+ >>
-IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
[ 2nip ] [
- >r [ gl-function-address ] attempt-each
+ >r [ gl-function-address ] map [ ] find nip
dup [ "OpenGL function not available" throw ] unless
dup r>
+gl-function-pointers+ get-global set-at
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs vocabs.loader sequences ;
+opengl.gl assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
TUPLE: sprite loc dim dim2 dlist texture ;
: <sprite> ( loc dim dim2 -- sprite )
- f f sprite construct-boa ;
+ f f sprite boa ;
: sprite-size2 sprite-dim2 first2 ;
swap comment-node present-text ;
: comment, ( ? node text -- )
- rot [ \ comment construct-boa , ] [ 2drop ] if ;
+ rot [ \ comment boa , ] [ 2drop ] if ;
: values% ( prefix values -- )
swap [
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
- { [ t ] [ words-called ] }
+ [ words-called ]
} cond 1 -rot get at+
] [
drop
: check-result ( result -- )
{
- { [ dup OCI_SUCCESS = ] [ drop ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ [ "operation failed" throw ]
+ } case ;
: check-status ( status -- bool )
{
- { [ dup OCI_SUCCESS = ] [ drop t ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ dup OCI_NO_DATA = ] [ drop f ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ t ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ { OCI_NO_DATA [ f ] }
+ [ "operation failed" throw ]
+ } case ;
! =========================================================
! Initialization and handle-allocation routines
>r stm get err get r> dup length swap malloc-char-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
-: calculate-size ( type -- size object )
+: calculate-size ( type -- size )
{
- { [ dup SQLT_INT = ] [ "int" heap-size ] }
- { [ dup SQLT_FLT = ] [ "float" heap-size ] }
- { [ dup SQLT_CHR = ] [ "char" heap-size ] }
- { [ dup SQLT_NUM = ] [ "int" heap-size 10 * ] }
- { [ dup SQLT_STR = ] [ 64 ] }
- { [ dup SQLT_ODT = ] [ 256 ] }
- } cond ;
+ { SQLT_INT [ "int" heap-size ] }
+ { SQLT_FLT [ "float" heap-size ] }
+ { SQLT_CHR [ "char" heap-size ] }
+ { SQLT_NUM [ "int" heap-size 10 * ] }
+ { SQLT_STR [ 64 ] }
+ { SQLT_ODT [ 256 ] }
+ } case ;
: define-by-position ( position type -- )
>r >r stm get f <void*> err get
- r> r> calculate-size swap >r [ "char" malloc-array dup buf set ] keep 1+
+ r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
: execute-statement ( -- bool )
USING: alien alien.c-types arrays assocs byte-arrays inference
-inference.transforms io io.binary io.streams.string kernel
-math math.parser namespaces parser prettyprint
-quotations sequences strings vectors
-words macros math.functions ;
+inference.transforms io io.binary io.streams.string kernel math
+math.parser namespaces parser prettyprint quotations sequences
+strings vectors words macros math.functions math.bitfields.lib ;
IN: pack
SYMBOL: big-endian
TUPLE: ensure-parser test ;
: ensure ( parser -- ensure )
- ensure-parser construct-boa ;
+ ensure-parser boa ;
M: ensure-parser parse ( input parser -- list )
2dup ensure-parser-test parse nil?
TUPLE: ensure-not-parser test ;
: ensure-not ( parser -- ensure )
- ensure-not-parser construct-boa ;
+ ensure-not-parser boa ;
M: ensure-not-parser parse ( input parser -- list )
2dup ensure-not-parser-test parse nil?
>r and-parser-parsers r> suffix
] [
2array
- ] if and-parser construct-boa ;
+ ] if and-parser boa ;
: <and-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ and-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ and-parser boa ] if ;
: and-parser-parse ( list p1 -- list )
swap [
TUPLE: or-parser parsers ;
: <or-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ or-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ or-parser boa ] if ;
: <|> ( parser1 parser2 -- parser )
2array <or-parser> ;
TUPLE: only-first-parser p1 ;
LAZY: only-first ( parser -- parser )
- only-first-parser construct-boa ;
+ only-first-parser boa ;
M: only-first-parser parse ( input parser -- list )
#! Transform a parser into a parser that only yields
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
"x[i][j].y" primary parse-result-ast
] unit-test
+
+'ebnf' compile must-infer
\r
M: ebnf-action (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
- string-lines [ parse-lines ] with-compilation-unit action ;\r
+ string-lines parse-lines action ;\r
\r
M: ebnf-semantic (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
- string-lines [ parse-lines ] with-compilation-unit semantic ;\r
+ string-lines parse-lines semantic ;\r
\r
M: ebnf-var (transform) ( ast -- parser )\r
parser>> (transform) ;\r
[ compiled-parse ] curry [ with-scope ] curry ;\r
\r
: replace-escapes ( string -- string )\r
- "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;\r
+ [\r
+ "\\t" token [ drop "\t" ] action ,\r
+ "\\n" token [ drop "\n" ] action ,\r
+ "\\r" token [ drop "\r" ] action ,\r
+ ] choice* replace ;\r
\r
: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing\r
\r
"of characters separated with a dash (-) represents the "
"range of characters from the first to the second, inclusive."
{ $examples
- { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
- { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" }
+ { $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
+ { $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
}
} ;
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib math.parser match
+ vectors arrays combinators.lib math.parser
unicode.categories sequences.deep peg peg.private
peg.search math.ranges words memoize ;
IN: peg.parsers
just-parser-p1 compiled-parser just-pattern curry ;
MEMO: just ( parser -- parser )
- just-parser construct-boa init-parser ;
+ just-parser boa init-parser ;
: 1token ( ch -- parser ) 1string token ;
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "\r
"the AST produced by 'p1' on the stack returns true." }\r
{ $examples \r
- { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } \r
- { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } \r
+ { $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" } \r
+ { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" } \r
} ;\r
\r
HELP: ensure\r
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib math.parser match
- unicode.categories sequences.lib compiler.units parser
- words quotations effects memoize accessors locals effects ;
+USING: kernel sequences strings fry namespaces math assocs shuffle
+ vectors arrays math.parser
+ unicode.categories compiler.units parser
+ words quotations effects memoize accessors locals effects splitting ;
IN: peg
USE: prettyprint
SYMBOL: ignore
: <parse-result> ( remaining ast -- parse-result )
- parse-result construct-boa ;
+ parse-result boa ;
SYMBOL: packrat
SYMBOL: pos
SYMBOL: lrstack
SYMBOL: heads
+: failed? ( obj -- ? )
+ fail = ;
+
: delegates ( -- cache )
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
#! that maps the position to the parser result.
id>> packrat get [ drop H{ } clone ] cache ;
+: process-rule-result ( p result -- result )
+ [
+ nip [ ast>> ] [ remaining>> ] bi input-from pos set
+ ] [
+ pos set fail
+ ] if* ;
+
: eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
#! stack effect ( input -- parse-result )
- pos get swap
- execute
-! drop f f <parse-result>
- [
- nip
- [ ast>> ] [ remaining>> ] bi
- input-from pos set
- ] [
- pos set
- fail
- ] if* ; inline
+ pos get swap execute process-rule-result ; inline
: memo ( pos rule -- memo-entry )
#! Return the result from the memo cache.
#! Store an entry in the cache
rule-parser input-cache set-at ;
-:: (grow-lr) ( r p m h -- )
- p pos set
- h involved-set>> clone h (>>eval-set)
- r eval-rule
- dup fail = pos get m pos>> <= or [
- drop
+: update-m ( ast m -- )
+ swap >>ans pos get >>pos drop ;
+
+: stop-growth? ( ast m -- ? )
+ [ failed? pos get ] dip
+ pos>> <= or ;
+
+: setup-growth ( h p -- )
+ pos set dup involved-set>> clone >>eval-set drop ;
+
+: (grow-lr) ( h p r m -- )
+ >r >r [ setup-growth ] 2keep r> r>
+ >r dup eval-rule r> swap
+ dup pick stop-growth? [
+ 4drop drop
] [
- m (>>ans)
- pos get m (>>pos)
- r p m h (grow-lr)
+ over update-m
+ (grow-lr)
] if ; inline
-:: grow-lr ( r p m h -- ast )
- h p heads get set-at
- r p m h (grow-lr)
- p heads get delete-at
- m pos>> pos set m ans>>
+: grow-lr ( h p r m -- ast )
+ >r >r [ heads get set-at ] 2keep r> r>
+ pick over >r >r (grow-lr) r> r>
+ swap heads get delete-at
+ dup pos>> pos set ans>>
; inline
:: (setup-lr) ( r l s -- )
|
h rule>> r eq? [
m ans>> seed>> m (>>ans)
- m ans>> fail = [
+ m ans>> failed? [
fail
] [
- r p m h grow-lr
+ h p r m grow-lr
] if
] [
m ans>> seed>>
r h eval-set>> member? [
h [ r swap remove ] change-eval-set drop
r eval-rule
- m (>>ans)
- pos get m (>>pos)
+ m update-m
m
] [
m
] if
] ; inline
-:: apply-memo-rule ( r m -- ast )
- m pos>> pos set
- m ans>> left-recursion? [
- r m ans>> setup-lr
- m ans>> seed>>
+: apply-memo-rule ( r m -- ast )
+ [ ans>> ] [ pos>> ] bi pos set
+ dup left-recursion? [
+ [ setup-lr ] keep seed>>
] [
- m ans>>
- ] if ;
+ nip
+ ] if ;
-:: apply-rule ( r p -- ast )
- [let* |
- m [ r p recall ]
- |
- m [
- r m apply-memo-rule
- ] [
- r p apply-non-memo-rule
- ] if
- ] ; inline
+: apply-rule ( r p -- ast )
+ 2dup recall [
+ nip apply-memo-rule
+ ] [
+ apply-non-memo-rule
+ ] if* ; inline
: with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active.
GENERIC: (compile) ( parser -- quot )
+: execute-parser ( word -- result )
+ pos get apply-rule dup failed? [
+ drop f
+ ] [
+ input-slice swap <parse-result>
+ ] if ; inline
-:: parser-body ( parser -- quot )
+: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- [let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
- |
- [
- rule pos get apply-rule dup fail = [
- drop f
- ] [
- input-slice swap <parse-result>
- ] if
- ]
- ] ;
+ gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
+ [ execute-parser ] curry ;
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
+SYMBOL: delayed
+
+: fixup-delayed ( -- )
+ #! Work through all delayed parsers and recompile their
+ #! words to have the correct bodies.
+ delayed get [
+ call compiled-parser 1quotation 0 1 <effect> define-declared
+ ] assoc-each ;
+
: compile ( parser -- word )
- [ compiled-parser ] with-compilation-unit ;
+ [
+ H{ } clone delayed [
+ compiled-parser fixup-delayed
+ ] with-variable
+ ] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [ execute ] with-packrat ; inline
-: parse ( state parser -- result )
+: parse ( input parser -- result )
dup word? [ compile ] unless compiled-parse ;
<PRIVATE
TUPLE: token-parser symbol ;
-MATCH-VARS: ?token ;
-
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
- 2dup head? [
- dup >r length tail-slice r> <parse-result>
+ dup >r ?head-slice [
+ r> <parse-result>
] [
- 2drop f
+ r> 2drop f
] if ;
M: token-parser (compile) ( parser -- quot )
- [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ;
+ symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ;
-MATCH-VARS: ?quot ;
+: parse-satisfy ( input quot -- result )
+ swap dup empty? [
+ 2drop f
+ ] [
+ unclip-slice rot dupd call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if ; inline
-: satisfy-pattern ( -- quot )
- [
- input-slice dup empty? [
- drop f
- ] [
- unclip-slice dup ?quot call [
- <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
M: satisfy-parser (compile) ( parser -- quot )
- quot>> \ ?quot satisfy-pattern match-replace ;
+ quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ;
-MATCH-VARS: ?min ?max ;
-
-: range-pattern ( -- quot )
- [
- input-slice dup empty? [
+: parse-range ( input min max -- result )
+ pick empty? [
+ 3drop f
+ ] [
+ pick first -rot between? [
+ unclip-slice <parse-result>
+ ] [
drop f
- ] [
- 0 over nth dup
- ?min ?max between? [
- [ 1 tail-slice ] dip <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
+ ] if
+ ] if ;
M: range-parser (compile) ( parser -- quot )
- T{ range-parser _ ?min ?max } range-pattern match-replace ;
+ [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ;
-: seq-pattern ( -- quot )
+: ignore? ( ast -- bool )
+ ignore = ;
+
+: calc-seq-result ( prev-result current-result -- next-result )
[
- dup [
- ?quot [
- [ remaining>> swap (>>remaining) ] 2keep
- ast>> dup ignore = [
- drop
- ] [
- swap [ ast>> push ] keep
- ] if
- ] [
- drop f
- ] if*
+ [ remaining>> swap (>>remaining) ] 2keep
+ ast>> dup ignore? [
+ drop
] [
- drop f
- ] if
- ] ;
+ swap [ ast>> push ] keep
+ ] if
+ ] [
+ drop f
+ ] if* ;
+
+: parse-seq-element ( result quot -- result )
+ over [
+ call calc-seq-result
+ ] [
+ 2drop f
+ ] if ; inline
M: seq-parser (compile) ( parser -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
- parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
-: choice-pattern ( -- quot )
- [
- [ ?quot ] unless*
- ] ;
-
M: choice-parser (compile) ( parser -- quot )
[
f ,
- parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ unless* , ] each
] [ ] make ;
TUPLE: repeat0-parser p1 ;
-: (repeat0) ( quot result -- result )
+: (repeat) ( quot result -- result )
over call [
[ remaining>> swap (>>remaining) ] 2keep
ast>> swap [ ast>> push ] keep
- (repeat0)
- ] [
+ (repeat)
+ ] [
nip
] if* ; inline
-: repeat0-pattern ( -- quot )
- [
- [ ?quot ] swap (repeat0)
- ] ;
-
M: repeat0-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat0-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat)
+ ] ;
TUPLE: repeat1-parser p1 ;
-: repeat1-pattern ( -- quot )
+: repeat1-empty-check ( result -- result )
[
- [ ?quot ] swap (repeat0) [
- dup ast>> empty? [
- drop f
- ] when
- ] [
- f
- ] if*
- ] ;
+ dup ast>> empty? [ drop f ] when
+ ] [
+ f
+ ] if* ;
M: repeat1-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat1-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
+ ] ;
TUPLE: optional-parser p1 ;
-: optional-pattern ( -- quot )
- [
- ?quot [ input-slice f <parse-result> ] unless*
- ] ;
+: check-optional ( result -- result )
+ [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot optional-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
-MATCH-VARS: ?parser ;
-
-: semantic-pattern ( -- quot )
- [
- ?parser [
- dup parse-result-ast ?quot call [ drop f ] unless
- ] [
- f
- ] if*
- ] ;
+: check-semantic ( result quot -- result )
+ over [
+ over ast>> swap call [ drop f ] unless
+ ] [
+ drop
+ ] if ; inline
M: semantic-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?parser ?quot } semantic-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
+ '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ;
-: ensure-pattern ( -- quot )
- [
- input-slice ?quot [
- ignore <parse-result>
- ] [
- drop f
- ] if
- ] ;
+: check-ensure ( old-input result -- result )
+ [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
-: ensure-not-pattern ( -- quot )
- [
- input-slice ?quot [
- drop f
- ] [
- ignore <parse-result>
- ] if
- ] ;
+: check-ensure-not ( old-input result -- result )
+ [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
-MATCH-VARS: ?action ;
-
-: action-pattern ( -- quot )
- [
- ?quot dup [
- dup ast>> ?action call
- >>ast
- ] when
- ] ;
+: check-action ( result quot -- result )
+ over [
+ over ast>> swap call >>ast
+ ] [
+ drop
+ ] if ; inline
M: action-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?quot ?action } action-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot )
- [
- \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser ,
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice left-trim-slice input-from pos set @
+ ] ;
TUPLE: delay-parser quot ;
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
- [
- quot>> % \ compile ,
- ] [ ] make
- { } { "word" } <effect> memoize-quot
- [ % \ execute , ] [ ] make ;
+ quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ;
PRIVATE>
: token ( string -- parser )
- token-parser construct-boa init-parser ;
+ token-parser boa init-parser ;
: satisfy ( quot -- parser )
- satisfy-parser construct-boa init-parser ;
+ satisfy-parser boa init-parser ;
: range ( min max -- parser )
- range-parser construct-boa init-parser ;
+ range-parser boa init-parser ;
: seq ( seq -- parser )
- seq-parser construct-boa init-parser ;
+ seq-parser boa init-parser ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser construct-boa init-parser ;
+ choice-parser boa init-parser ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
{ } make choice ; inline
: repeat0 ( parser -- parser )
- repeat0-parser construct-boa init-parser ;
+ repeat0-parser boa init-parser ;
: repeat1 ( parser -- parser )
- repeat1-parser construct-boa init-parser ;
+ repeat1-parser boa init-parser ;
: optional ( parser -- parser )
- optional-parser construct-boa init-parser ;
+ optional-parser boa init-parser ;
: semantic ( parser quot -- parser )
- semantic-parser construct-boa init-parser ;
+ semantic-parser boa init-parser ;
: ensure ( parser -- parser )
- ensure-parser construct-boa init-parser ;
+ ensure-parser boa init-parser ;
: ensure-not ( parser -- parser )
- ensure-not-parser construct-boa init-parser ;
+ ensure-not-parser boa init-parser ;
: action ( parser quot -- parser )
- action-parser construct-boa init-parser ;
+ action-parser boa init-parser ;
: sp ( parser -- parser )
- sp-parser construct-boa init-parser ;
+ sp-parser boa init-parser ;
: hide ( parser -- parser )
[ drop ignore ] action ;
: delay ( quot -- parser )
- delay-parser construct-boa init-parser ;
+ delay-parser boa init-parser ;
: box ( quot -- parser )
#! because a box has its quotation run at compile time
#! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed...
- box-parser
construct-boa next-id f <parser> over set-delegate [ ] action ;
+ box-parser boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
{ [ 1 over consonant-end? not ] [ drop f ] }
{ [ 2 over consonant-end? ] [ drop f ] }
{ [ 3 over consonant-end? not ] [ drop f ] }
- { [ t ] [ "wxy" last-is? not ] }
+ [ "wxy" last-is? not ]
} cond ;
: r ( str oldsuffix newsuffix -- str )
{ [ "ies" ?tail ] [ "i" append ] }
{ [ dup "ss" tail? ] [ ] }
{ [ "s" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond
] when ;
{
{ [ "ed" ?tail ] [ -ed ] }
{ [ "ing" ?tail ] [ -ing ] }
- { [ t ] [ f ] }
+ [ f ]
} cond
] [ -ed/ing ]
}
- { [ t ] [ ] }
+ [ ]
} cond ;
: step1c ( str -- newstr )
{ [ "iviti" ?tail ] [ "iviti" "ive" r ] }
{ [ "biliti" ?tail ] [ "biliti" "ble" r ] }
{ [ "logi" ?tail ] [ "logi" "log" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step3 ( str -- newstr )
{ [ "ical" ?tail ] [ "ical" "ic" r ] }
{ [ "ful" ?tail ] [ "ful" "" r ] }
{ [ "ness" ?tail ] [ "ness" "" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: -ion ( str -- newstr )
{ [ "ous" ?tail ] [ ] }
{ [ "ive" ?tail ] [ ] }
{ [ "ize" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond dup consonant-seq 1 > [ nip ] [ drop ] if ;
: remove-e? ( str -- ? )
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step5 ( str -- newstr ) remove-e ll->l ;
--- /dev/null
+
+USING: kernel sequences ;
+
+IN: processing.color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: rgba red green blue alpha ;
+
+C: <rgba> rgba
+
+: <rgb> ( r g b -- rgba ) 1 <rgba> ;
+
+: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
+
+: {rgb} ( seq -- rgba ) first3 <rgb> ;
+
+! : hex>rgba ( hex -- rgba )
+
+! : set-gl-color ( color -- )
+! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
--- /dev/null
+
+USING: kernel namespaces combinators
+ ui.gestures qualified accessors ui.gadgets.frame-buffer ;
+
+IN: processing.gadget
+
+QUALIFIED: ui.gadgets
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: processing-gadget button-down button-up key-down key-up ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-gadget-delegate ( tuple gadget -- tuple )
+ over ui.gadgets:set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <processing-gadget> ( -- gadget )
+ processing-gadget new
+ <frame-buffer> set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+SYMBOL: key-pressed-value
+
+SYMBOL: button-value
+SYMBOL: key-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+: key ( -- key ) key-value get ;
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel arrays sequences math qualified
+ sequences.lib circular processing ui newfx ;
+
+IN: processing.gallery.trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
+
+: step ( seq -- )
+
+ no-stroke
+ { 1 0.4 } fill
+
+ 0 background
+
+ mouse push-circular
+ [ dot ]
+ each-percent ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( -- )
+
+ 500 500 size*
+
+ [
+ 100 point-list
+ [ step ]
+ curry
+ draw
+ ] setup
+
+ run ;
+
+: go ( -- ) [ go* ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces threads combinators sequences arrays
+ math math.functions math.ranges random
+ opengl.gl opengl.glu vars multi-methods shuffle
+ ui
+ ui.gestures
+ ui.gadgets
+ combinators
+ combinators.lib
+ combinators.cleave
+ rewrite-closures fry accessors newfx
+ processing.color
+ processing.gadget ;
+
+IN: processing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chance ( fraction -- ? ) 0 1 2random > ;
+
+: percent-chance ( percent -- ? ) 100 / chance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * at ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: set-color ( value -- )
+
+METHOD: set-color { number } dup dup glColor3d ;
+
+METHOD: set-color { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glColor4d ] }
+ { 3 [ first3 glColor3d ] }
+ { 4 [ first4 glColor4d ] }
+ }
+ case ;
+
+METHOD: set-color { rgba }
+ { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill ( value -- ) >fill-color ;
+: stroke ( value -- ) >stroke-color ;
+
+: no-fill ( -- )
+ fill-color>
+ {
+ { [ dup number? ] [ 0 2array fill ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+: no-stroke ( -- )
+ stroke-color>
+ {
+ { [ dup number? ] [ 0 2array stroke ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-weight ( w -- ) glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- )
+ stroke-color> set-color
+ GL_POINTS glBegin
+ glVertex2d
+ glEnd ;
+
+: point ( seq -- ) first2 point* ;
+
+: line ( x1 y1 x2 y2 -- )
+ stroke-color> set-color
+ GL_LINES glBegin
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangle ( x1 y1 x2 y2 x3 y3 -- )
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ 6 ndup
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+ GL_POLYGON glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+
+ 8 ndup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ quad-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ quad-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rect-vertices ( x y width height -- )
+ GL_POLYGON glBegin
+ [ 2drop glVertex2d ] 4keep
+ [ drop swap >r + 1- r> glVertex2d ] 4keep
+ [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
+ [ nip + 1- glVertex2d ] 4keep
+ 4drop
+ glEnd ;
+
+: rect ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ rect-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ rect-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ellipse-disk ( x y width height -- )
+ glPushMatrix
+ >r >r
+ 0 glTranslated
+ r> r> 1 glScaled
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+: ellipse-center ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ stroke-color> set-color
+
+ ellipse-disk
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
+
+ ellipse-disk ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: CENTER
+SYMBOL: RADIUS
+SYMBOL: CORNER
+SYMBOL: CORNERS
+
+SYMBOL: ellipse-mode-value
+
+: ellipse-mode ( val -- ) ellipse-mode-value set ;
+
+: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
+
+: ellipse-corner ( x y width height -- )
+ [ drop nip 2 / + ] 4keep
+ [ nip rot drop 2 / + ] 4keep
+ [ >r >r 2drop r> r> ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse-corners ( x1 y1 x2 y2 -- )
+ [ drop nip + 2 / ] 4keep
+ [ nip rot drop + 2 / ] 4keep
+ [ drop nip - abs 1+ ] 4keep
+ [ nip rot drop - abs 1+ ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse ( a b c d -- )
+ ellipse-mode-value get
+ {
+ { CENTER [ ellipse-center ] }
+ { RADIUS [ ellipse-radius ] }
+ { CORNER [ ellipse-corner ] }
+ { CORNERS [ ellipse-corners ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: multi-methods ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: background ( value -- )
+
+METHOD: background { number }
+ dup dup 1 glClearColor
+ GL_COLOR_BUFFER_BIT glClear ;
+
+METHOD: background { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: translate ( x y -- ) 0 glTranslated ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x mouse first ;
+: mouse-y mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: frame-rate-value
+
+: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: slate
+
+VAR: loop-flag
+
+: defaults ( -- )
+ 0.8 background
+ 0 >stroke-color
+ 1 >fill-color
+ CENTER ellipse-mode
+ 60 frame-rate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: size-val
+
+: size ( seq -- ) size-val set ;
+
+: size* ( width height -- ) 2array size-val set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-action
+SYMBOL: draw-action
+
+! : setup ( quot -- ) closed-quot setup-action set ;
+! : draw ( quot -- ) closed-quot draw-action set ;
+
+: setup ( quot -- ) setup-action set ;
+: draw ( quot -- ) draw-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-down-action
+SYMBOL: key-up-action
+
+: key-down ( quot -- ) closed-quot key-down-action set ;
+: key-up ( quot -- ) closed-quot key-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-down-action
+SYMBOL: button-up-action
+
+: button-down ( quot -- ) closed-quot button-down-action set ;
+: button-up ( quot -- ) closed-quot button-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-processing-thread ( -- )
+ loop-flag get not
+ [
+ loop-flag on
+ [
+ [ loop-flag get ]
+ processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
+ [ ]
+ while
+ ]
+ in-thread
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-size ( -- size ) processing-gadget get rect-dim ;
+
+: width ( -- width ) get-size first ;
+: height ( -- height ) get-size second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-called
+
+: setup-called? ( -- ? ) setup-called get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run ( -- )
+
+ loop-flag off
+
+ 500 sleep
+
+ <processing-gadget>
+ size-val get >>dim
+ dup "Processing" open-window
+
+ 500 sleep
+
+ defaults
+
+ setup-called off
+
+ [
+ setup-called? not
+ [
+ setup-action get call
+ setup-called on
+ ]
+ [
+ draw-action get call
+ ]
+ if
+ ]
+ closed-quot >>action
+
+ key-down-action get >>key-down
+ key-up-action get >>key-up
+
+ button-down-action get >>button-down
+ button-up-action get >>button-up
+
+ processing-gadget set
+
+ start-processing-thread ;
\ No newline at end of file
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
PRIVATE>
: euler023 ( -- answer )
- 20161 abundants-upto possible-sums source-023 seq-diff sum ;
+ 20161 abundants-upto possible-sums source-023 diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math.functions math.ranges project-euler.common
- sequences ;
+ sequences sets ;
IN: project-euler.029
! http://projecteuler.net/index.php?section=problems&id=29
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.functions
- math.parser math.ranges project-euler.common sequences ;
+ math.parser math.ranges project-euler.common sequences sets ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
- project-euler.common sequences sequences.lib ;
+ project-euler.common sequences sequences.lib sets ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
: possible? ( seq -- ? )
dup length 1 > [
- dup { 0 2 4 5 6 8 } swap seq-diff =
+ dup { 0 2 4 5 6 8 } swap diff =
] [
drop t
] if ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sequences.lib sorting ;
+ math.ranges project-euler.common sequences sequences.lib sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
[ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 seq-diff first prefix ;
+ dup natural-sort 10 diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces sequences sequences.lib sequences.private sorting
- splitting strings ;
+ splitting strings sets ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math sequences math.ranges locals ;
+IN: project-euler.076
+
+! http://projecteuler.net/index.php?section=problems&id=76
+
+! DESCRIPTION
+! -----------
+
+! How many different ways can one hundred be written as a
+! sum of at least two positive integers?
+
+! SOLUTION
+! --------
+
+! This solution uses dynamic programming and the following
+! recurence relation:
+
+! ways(0,_) = 1
+! ways(_,0) = 0
+! ways(n,i) = ways(n-i,i) + ways(n,i-1)
+
+<PRIVATE
+
+: init ( n -- table )
+ [1,b] [ 0 2array 0 ] H{ } map>assoc
+ 1 { 0 0 } pick set-at ;
+
+: use ( n i -- n i )
+ [ - dup ] keep min ; inline
+
+: ways ( n i table -- )
+ over zero? [
+ 3drop
+ ] [
+ [ [ 1- 2array ] dip at ]
+ [ [ use 2array ] dip at + ]
+ [ [ 2array ] dip set-at ] 3tri
+ ] if ;
+
+:: each-subproblem ( n quot -- )
+ n [1,b] [ dup [1,b] quot with each ] each ; inline
+
+PRIVATE>
+
+: (euler076) ( n -- m )
+ dup init
+ [ [ ways ] curry each-subproblem ]
+ [ [ dup 2array ] dip at 1- ] 2bi ;
+
+: euler076 ( -- m )
+ 100 (euler076) ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables io.files kernel math math.parser namespaces
-io.encodings.ascii sequences ;
+io.encodings.ascii sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
] { } make ;
: find-source ( seq -- elt )
- dup values swap keys [ prune ] bi@ seq-diff
+ dup values swap keys [ prune ] bi@ diff
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
: topological-sort ( seq -- seq )
[ [ (topological-sort) ] { } make ] keep
- concat prune dupd seq-diff append ;
+ concat prune dupd diff append ;
: euler079 ( -- answer )
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
! 2 ms run / 0 ms GC ave time - 100 trials
-! TODO: prune and seq-diff are relatively slow; topological sort could be
+! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
MAIN: euler079
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges sequences sequences.lib ;
+
+IN: project-euler.116
+
+! http://projecteuler.net/index.php?section=problems&id=116
+
+! DESCRIPTION
+! -----------
+
+! A row of five black square tiles is to have a number of its tiles replaced
+! with coloured oblong tiles chosen from red (length two), green (length
+! three), or blue (length four).
+
+! If red tiles are chosen there are exactly seven ways this can be done.
+! If green tiles are chosen there are three ways.
+! And if blue tiles are chosen there are two ways.
+
+! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
+! replacing the black tiles in a row measuring five units in length.
+
+! How many different ways can the black tiles in a row measuring fifty units in
+! length be replaced if colours cannot be mixed and at least one coloured tile
+! must be used?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(n,_) = 0 | n < 0
+! ways(0,_) = 1
+! ways(n,i) = ways(n-i,i) + ways(n-1,i)
+! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
+
+<PRIVATE
+
+: nth* ( n seq -- elt/0 )
+ [ length swap - 1- ] keep ?nth 0 or ;
+
+: next ( colortile seq -- )
+ [ nth* ] [ peek + ] [ push ] tri ;
+
+: ways ( length colortile -- permutations )
+ V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+
+PRIVATE>
+
+: (euler116) ( length -- permutations )
+ 3 [1,b] [ ways ] with sigma ;
+
+: euler116 ( -- permutations )
+ 50 (euler116) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math splitting sequences ;
+
+IN: project-euler.117
+
+! http://projecteuler.net/index.php?section=problems&id=117
+
+! DESCRIPTION
+! -----------
+
+! Using a combination of black square tiles and oblong tiles chosen
+! from: red tiles measuring two units, green tiles measuring three
+! units, and blue tiles measuring four units, it is possible to tile a
+! row measuring five units in length in exactly fifteen different ways.
+
+! How many ways can a row measuring fifty units in length be tiled?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(i) = 1 | i <= 0
+! ways(i) = ways(i-4) + ways(i-3) + ways(i-2) + ways(i-1)
+
+<PRIVATE
+
+: short ( seq n -- seq n )
+ over length min ;
+
+: next ( seq -- )
+ [ 4 short tail* sum ] keep push ;
+
+PRIVATE>
+
+: (euler117) ( n -- m )
+ V{ 1 } clone tuck [ next ] curry times peek ;
+
+: euler117 ( -- m )
+ 50 (euler117) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences locals ;
+IN: project-euler.150
+
+<PRIVATE
+
+! sequence helper functions
+
+: partial-sums ( seq -- seq )
+ 0 [ + ] accumulate swap suffix ; inline
+
+: generate ( n quot -- seq )
+ [ drop ] swap compose map ; inline
+
+: map-infimum ( seq quot -- min )
+ [ min ] compose 0 swap reduce ; inline
+
+
+! triangle generator functions
+
+: next ( t -- new-t s )
+ 615949 * 797807 + 1 20 shift mod dup 1 19 shift - ; inline
+
+: sums-triangle ( -- seq )
+ 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+
+PRIVATE>
+
+:: (euler150) ( m -- n )
+ [let | table [ sums-triangle ] |
+ m [| x |
+ x 1+ [| y |
+ m x - [| z |
+ x z + table nth
+ [ y z + 1+ swap nth ]
+ [ y swap nth ] bi -
+ ] map partial-sums infimum
+ ] map-infimum
+ ] map-infimum
+ ] ;
+
+: euler150 ( -- n )
+ 1000 (euler150) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel math math.ranges sequences ;
+
+IN: project-euler.164
+
+! http://projecteuler.net/index.php?section=problems&id=164
+
+! DESCRIPTION
+! -----------
+
+! How many 20 digit numbers n (without any leading zero) exist such
+! that no three consecutive digits of n have a sum greater than 9?
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: next-keys ( key -- keys )
+ [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+
+: next-table ( assoc -- assoc )
+ H{ } clone swap
+ [ swap next-keys [ pick at+ ] with each ] assoc-each ;
+
+: init-table ( -- assoc )
+ 9 [1,b] [ 1array 1 ] H{ } map>assoc ;
+
+PRIVATE>
+
+: euler164 ( -- n )
+ init-table 19 [ next-table ] times values sum ;
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] keep 1- fn + ] }
+ [ 2/ [ fn ] [ 1- fn ] bi + ]
} cond ;
: euler169 ( -- result )
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
- { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
+ [ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
PRIVATE>
--- /dev/null
+USING: circular disjoint-set kernel math math.ranges
+ sequences sequences.lib ;
+IN: project-euler.186
+
+: (generator) ( k -- n )
+ dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
+
+: <generator> ( -- lag )
+ 55 [1,b] [ (generator) ] map <circular> ;
+
+: advance ( lag -- )
+ [ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
+
+: next ( lag -- n )
+ [ first ] [ advance ] bi ;
+
+: 2unless? ( x y ?quot quot -- )
+ >r 2keep rot [ 2drop ] r> if ; inline
+
+: (p186) ( generator counter unionfind -- counter )
+ 524287 over equiv-set-size 990000 <
+ [
+ pick [ next ] [ next ] bi
+ [ = ] [
+ pick equate
+ [ 1+ ] dip
+ ] 2unless? (p186)
+ ] [
+ drop nip
+ ] if ;
+
+: euler186 ( -- n )
+ <generator> 0 1000000 <disjoint-set> (p186) ;
+
+MAIN: euler186
Aaron Schaefer
+Eric Mertens
TUPLE: promise quot forced? value ;
: promise ( quot -- promise )
- f f \ promise construct-boa ;
+ f f \ promise boa ;
: promise-with ( value quot -- promise )
curry promise ;
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $code
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
+
+HELP: QUALIFIED-WITH:
+{ $syntax "QUALIFIED-WITH: vocab prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $examples { $code
+ "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
+
+HELP: FROM:
+{ $syntax "FROM: vocab => words ... ;" }
+{ $description "Imports the specified words from vocab." }
+{ $examples { $code
+ "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+
+HELP: EXCLUDE:
+{ $syntax "EXCLUDE: vocab => words ... ;" }
+{ $description "Imports everything from vocab excluding the specified words" }
+{ $examples { $code
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+
+HELP: RENAME:
+{ $syntax "RENAME: word vocab => newname " }
+{ $description "Imports word from vocab, but renamed to newname." }
+{ $examples { $code
+ "RENAME: + math => -"
+ "2 3 - ! => 5" } } ;
+
: x 1 ;
IN: bar
: x 2 ;
+IN: baz
+: x 3 ;
+
QUALIFIED: foo
QUALIFIED: bar
-[ 1 2 2 ] [ foo:x bar:x x ] unit-test
+[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+
+QUALIFIED-WITH: bar p
+[ 2 ] [ p:x ] unit-test
+
+RENAME: x baz => y
+[ 3 ] [ y ] unit-test
+
+FROM: baz => x ;
+[ 3 ] [ x ] unit-test
+
+EXCLUDE: bar => x ;
+[ 3 ] [ x ] unit-test
+
-USING: kernel sequences assocs parser vocabs namespaces
-vocabs.loader ;
+USING: kernel sequences assocs hashtables parser vocabs words namespaces
+vocabs.loader debugger sets ;
IN: qualified
-: define-qualified ( vocab-name -- )
- dup require
- dup vocab-words swap CHAR: : suffix
+: define-qualified ( vocab-name prefix-name -- )
+ [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
[ -rot >r append r> ] curry assoc-map
use get push ;
-
: QUALIFIED:
- scan define-qualified ; parsing
+ #! Syntax: QUALIFIED: vocab
+ scan dup define-qualified ; parsing
+
+: QUALIFIED-WITH:
+ #! Syntax: QUALIFIED-WITH: vocab prefix
+ scan scan define-qualified ; parsing
+
+: expect=> scan "=>" assert= ;
+
+: partial-vocab ( words name -- assoc )
+ dupd [
+ lookup [ "No such word: " swap append throw ] unless*
+ ] curry map zip ;
+
+: partial-vocab-ignoring ( words name -- assoc )
+ [ vocab-words keys diff ] keep partial-vocab ;
+
+: EXCLUDE:
+ #! Syntax: EXCLUDE: vocab => words ... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
+
+: FROM:
+ #! Syntax: FROM: vocab => words... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab use get push ; parsing
+
+: RENAME:
+ #! Syntax: RENAME: word vocab => newname
+ scan scan lookup [ "No such word" throw ] unless*
+ expect=>
+ scan associate use get push ; parsing
+
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math.constants ;
-IN: random-tester.databank
-
-: databank ( -- array )
- {
- ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
- pi 1/0. -1/0. 0/0. [ ]
- f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
- C{ 2 2 } C{ 1/0. 1/0. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-USING: random-tester.databank random-tester.safe-words ;
-IN: random-tester
-
-SYMBOL: errored
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-TUPLE: random-tester-error ;
-
-: setup-test ( #data #code -- data... quot )
- #! Variable stack effect
- >r [ databank random ] times r>
- [ drop \ safe-words get random ] map >quotation ;
-
-: test-compiler ! ( data... quot -- ... )
- errored off
- dup quot set
- datastack 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ errored on ] recover ;
-
-: do-test ! ( data... quot -- )
- .s flush test-compiler
- errored get [
- datastack after get 2dup = [
- 2drop
- ] [
- [ . ] each
- "--" print
- [ . ] each
- quot get .
- random-tester-error construct-empty throw
- ] if
- ] unless clear ;
-
-: random-test1 ( #data #code -- )
- setup-test do-test ;
-
-: random-test2 ( -- )
- 3 2 setup-test do-test ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint optimizer
-random math.constants math.functions layouts random-tester.utils ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel namespaces sequences sorting vocabs ;
-USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
-IN: random-tester.safe-words
-
-: ?-words
- {
- delegate
-
- /f
-
- bits>float bits>double
- float>bits double>bits
-
- >bignum >boolean >fixnum >float
-
- array? integer? complex? value-ref? ref? key-ref?
- interval? number?
- wrapper? tuple?
- [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
- 2^ not
- ! arrays
- resize-array <array>
- ! assocs
- (assoc-stack)
- new-assoc
- assoc-like
- <hashtable>
- all-integers? (all-integers?) ! hangs?
- assoc-push-if
-
- (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
- } ;
-
-: bignum-words
- {
- next-power-of-2 (next-power-of-2)
- times
- hashcode hashcode*
- } ;
-
-: initialization-words
- {
- init-namespaces
- } ;
-
-: stack-words
- {
- dup
- drop 2drop 3drop
- roll -roll 2swap
-
- >r r>
- } ;
-
-: method-words
- {
- forget-word
- } ;
-
-: stateful-words
- {
- counter
- gensym
- } ;
-
-: foo-words
- {
- set-retainstack
- retainstack callstack
- datastack
- callstack>array
- } ;
-
-: exit-words
- {
- call-clear die
- } ;
-
-: bad-words ( -- array )
- [
- ?-words %
- bignum-words %
- initialization-words %
- stack-words %
- method-words %
- stateful-words %
- exit-words %
- foo-words %
- ] { } make ;
-
-: safe-words ( -- array )
- bad-words {
- "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
- ! "classes" "combinators" "compiler" "continuations"
- ! "core-foundation" "definitions" "documents"
- ! "float-arrays" "generic" "graphs" "growable"
- "hashtables" ! io.*
- "kernel" "math"
- "math.bitfields" "math.complex" "math.constants" "math.floats"
- "math.functions" "math.integers" "math.intervals" "math.libm"
- "math.parser" "math.ratios" "math.vectors"
- ! "namespaces" "quotations" "sbufs"
- ! "queues" "strings" "sequences"
- "vectors"
- ! "words"
- } [ words ] map concat seq-diff natural-sort ;
-
-safe-words \ safe-words set-global
-
-! foo dup (clone) = .
-! foo dup clone = .
-! f [ byte-array>bignum assoc-clone-like ] compile-1
-! 2 3.14 [ construct-empty number= ] compile-1
-! 3.14 [ <vector> assoc? ] compile-1
-! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize namespaces quotations random sequences
-sequences.private shuffle ;
-IN: random-tester.utils
-
-: %chance ( n -- ? )
- 100 random > ;
-
-: 10% ( -- ? ) 10 %chance ;
-: 20% ( -- ? ) 20 %chance ;
-: 30% ( -- ? ) 30 %chance ;
-: 40% ( -- ? ) 40 %chance ;
-: 50% ( -- ? ) 50 %chance ;
-: 60% ( -- ? ) 60 %chance ;
-: 70% ( -- ? ) 70 %chance ;
-: 80% ( -- ? ) 80 %chance ;
-: 90% ( -- ? ) 90 %chance ;
-
-: call-if ( quot ? -- ) swap when ; inline
-
-: with-10% ( quot -- ) 10% call-if ; inline
-: with-20% ( quot -- ) 20% call-if ; inline
-: with-30% ( quot -- ) 30% call-if ; inline
-: with-40% ( quot -- ) 40% call-if ; inline
-: with-50% ( quot -- ) 50% call-if ; inline
-: with-60% ( quot -- ) 60% call-if ; inline
-: with-70% ( quot -- ) 70% call-if ; inline
-: with-80% ( quot -- ) 80% call-if ; inline
-: with-90% ( quot -- ) 90% call-if ; inline
-
-: random-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
--- /dev/null
+USING: kernel math tools.test namespaces random
+random.blum-blum-shub alien.c-types sequences splitting ;
+IN: blum-blum-shub.tests
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
+] unit-test
+
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 32 random-bits
+ little-endian? [ <uint> reverse *uint ] unless
+ ] with-random
+] unit-test
+
+[ 5726770047455156646 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 64 random-bits
+ little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
+ ] with-random
+] unit-test
+
+[ 3716213681 ]
+[
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
+ random-32* drop
+ ] curry times
+ random-32*
+] unit-test
math.functions accessors random ;
IN: random.blum-blum-shub
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
+! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
+! return low bit of x+1
TUPLE: blum-blum-shub x n ;
-C: <blum-blum-shub> blum-blum-shub
+<PRIVATE
: generate-bbs-primes ( numbits -- p q )
- #! two primes congruent to 3 (mod 4)
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
-IN: crypto
+: next-bbs-bit ( bbs -- bit )
+ [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
: <blum-blum-shub> ( numbits -- blum-blum-shub )
- #! returns a Blum-Blum-Shub tuple
generate-bbs-primes *
[ find-relative-prime ] keep
- blum-blum-shub construct-boa ;
-
-! 256 make-bbs blum-blum-shub set-global
-
-: next-bbs-bit ( bbs -- bit )
- #! x = x^2 mod n, return low bit of calculated x
- [ [ x>> 2 ] [ n>> ] bi ^mod ]
- [ [ >>x ] keep x>> 1 bitand ] bi ;
-
-IN: crypto
-! : random ( n -- n )
- ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
- ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
+ blum-blum-shub boa ;
M: blum-blum-shub random-32* ( bbs -- r )
- ;
+ 0 32 rot
+ [ next-bbs-bit swap 1 shift bitor ] curry times ;
PRIVATE>
: <mersenne-twister> ( seed -- obj )
- init-mt-seq 0 mersenne-twister construct-boa
+ init-mt-seq 0 mersenne-twister boa
dup mt-generate ;
M: mersenne-twister seed-random ( mt seed -- )
inspector ;
IN: random
-SYMBOL: insecure-random-generator
+SYMBOL: system-random-generator
SYMBOL: secure-random-generator
SYMBOL: random-generator
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
+: with-system-random ( quot -- )
+ system-random-generator get swap with-random ; inline
+
: with-secure-random ( quot -- )
- >r secure-random-generator get r> with-random ; inline
+ secure-random-generator get swap with-random ; inline
os openbsd? [
[
"/dev/srandom" <unix-random> secure-random-generator set-global
- "/dev/prandom" <unix-random> insecure-random-generator set-global
+ "/dev/arandom" <unix-random> system-random-generator set-global
] "random.unix" add-init-hook
] [
[
"/dev/random" <unix-random> secure-random-generator set-global
- "/dev/urandom" <unix-random> insecure-random-generator set-global
+ "/dev/urandom" <unix-random> system-random-generator set-global
] "random.unix" add-init-hook
] if
[
MS_DEF_PROV
- PROV_RSA_FULL <windows-rng> insecure-random-generator set-global
+ PROV_RSA_FULL <windows-rng> system-random-generator set-global
MS_STRONG_PROV
PROV_RSA_FULL <windows-rng> secure-random-generator set-global
[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
+
+! Bug in parsing word
+[ t ] [
+ "a"
+ R' a'
+ matches?
+] unit-test
ignore-case? [
dup 'regexp' just parse-1
] with-variable
- ] keep regexp construct-boa ;
+ ] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
} case ;
: parse-regexp ( accum end -- accum )
- lexer get dup skip-blank [
- [ index* dup 1+ swap ] 2keep swapd subseq swap
- ] change-lexer-column
- lexer get (parse-token) parse-options <regexp> parsed ;
+ lexer get dup skip-blank
+ [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
+ lexer get dup still-parsing-line?
+ [ (parse-token) parse-options ] [ drop f ] if
+ <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing
: R" CHAR: " parse-regexp ; parsing
noise first2 {\r
{ [ over 4 <= ] [ >r drop 0 r> ] }\r
{ [ over 15 >= ] [ >r 2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond\r
{\r
! short words are easier to read\r
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }\r
{ [ dup 20 >= ] [ >r 5/3 * r> ] }\r
{ [ dup 15 >= ] [ >r 3/2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond noise-factor ;\r
\r
GENERIC: word-noise-factor ( word -- factor )\r
dup 1 3999 between? [
drop
] [
- roman-range-error construct-boa throw
+ roman-range-error boa throw
] if ;
: roman<= ( ch1 ch2 -- ? )
{
{ [ dup letter? ] [ CHAR: a rotate ] }
{ [ dup LETTER? ] [ CHAR: A rotate ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: rot13 ( string -- string ) [ rot-letter ] map ;
-USING: rss io kernel io.files tools.test io.encodings.utf8 ;
+USING: rss io kernel io.files tools.test io.encodings.utf8
+calendar ;
IN: rss.tests
: load-news-file ( filename -- feed )
"http://example.org/2005/04/02/atom"
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
- "2003-12-13T08:29:29-04:00"
+ T{ timestamp f 2003 12 13 8 29 29 -4 }
}
}
} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
USING: xml.utilities kernel assocs xml.generator
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables ;
-
-: ?children>string ( tag/f -- string/f )
- [ children>string ] [ f ] if* ;
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations ;
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named ?children>string
+ tag-named dup [ children>string rfc3339>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string <entry> ;
+ "pubDate" tag-named children>string rfc3339>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
[ children>string ] if
] keep
{ "published" "updated" "issued" "modified" } any-tag-named
- children>string <entry> ;
+ children>string rfc3339>timestamp <entry> ;
: atom1.0 ( xml -- feed )
[ "title" tag-named children>string ] keep
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get-stream rot success? [
- nip read-feed
+ http-get-stream swap code>> success? [
+ read-feed
] [
- 2drop "Error retrieving newsfeed file" throw
+ dispose "Error retrieving newsfeed file" throw
] if ;
! Atom generation
"entry" [
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
- dup entry-pub-date "published" simple-tag,
+ dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel
+USING: accessors db.tuples hashtables kernel sets
semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy
TUPLE: node id content ;
: <node> ( content -- node )
- node construct-empty swap >>content ;
+ node new swap >>content ;
: <id-node> ( id -- node )
- node construct-empty swap >>id ;
+ node new swap >>id ;
node "node"
{
TUPLE: arc id relation subject object ;
: <arc> ( relation subject object -- arc )
- arc construct-empty swap >>object swap >>subject swap >>relation ;
+ arc new swap >>object swap >>subject swap >>relation ;
: <id-arc> ( id -- arc )
- arc construct-empty swap >>id ;
+ arc new swap >>id ;
: insert-arc ( arc -- )
f <node> dup insert-tuple id>> >>id insert-tuple ;
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations ;
+assocs.lib quotations hashtables ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: each-percent ( seq quot -- )
+ >r
+ dup length
+ dup [ / ] curry
+ [ 1+ ] swap compose
+ r> compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: sigma ( seq quot -- n )
[ rot slip + ] curry 0 swap reduce ; inline
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
-: nths ( indices seq -- seq' )
- [ swap nth ] with map ;
+: nths ( seq indices -- seq' )
+ swap [ nth ] curry map ;
: replace ( str oldseq newseq -- str' )
- H{ } 2seq>assoc substitute ;
+ zip >hashtable substitute ;
: remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ;
--- /dev/null
+Non-core sequence words
: map-next ( seq quot -- newseq )
! quot: next-elt elt -- newelt
- over dup length swap new >r
+ over dup length swap new-sequence >r
iterate-seq [ (map-next) ] 2curry
r> [ collect ] keep ; inline
--- /dev/null
+Iteration with access to next element
read1 {
{ [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
{ [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
- { [ t ] [ read be> ] }
+ [ read be> ]
} cond ;
: serialize-shared ( obj quot -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
- { [ t ] [ serialize-word ] }
+ [ serialize-word ]
} cond ;
M: wrapper (serialize) ( obj -- )
(deserialize) <wrapper> ;
:: (deserialize-seq) ( exemplar quot -- seq )
- deserialize-cell exemplar new
+ deserialize-cell exemplar new-sequence
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
#! slots
- (deserialize) construct-empty
+ (deserialize) new
[ intern-object ]
[
[ (deserialize) ]
--- /dev/null
+
+USING: kernel arrays strings sequences sequences.deep peg peg.ebnf ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: incantation command stdin stdout background ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+
+TUPLE: variable-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <single-quoted-expr> single-quoted-expr boa ;
+: <double-quoted-expr> double-quoted-expr boa ;
+: <back-quoted-expr> back-quoted-expr boa ;
+: <glob-expr> glob-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+whitespace = (white)* => [[ drop ignore ]]
+
+squote = "'"
+
+single-quoted = squote (!(squote) .)* squote => [[ second >string <single-quoted-expr> ]]
+
+dquote = '"'
+
+double-quoted = dquote (!(dquote) .)* dquote => [[ second >string <double-quoted-expr> ]]
+
+bquote = "`"
+
+back-quoted = bquote (!(bquote) .)* bquote => [[ second >string <back-quoted-expr> ]]
+
+variable = "$" other => [[ second variable-expr boa ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ flatten concat <glob-expr> ]]
+
+other = (!(white | "&" | ">" | ">>" | "<") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | variable | glob | other)
+
+to-file = ">" whitespace other => [[ second ]]
+
+in-file = "<" whitespace other => [[ second ]]
+
+ap-file = ">>" whitespace other => [[ second ]]
+
+redirection = (in-file)? whitespace (to-file | ap-file)?
+
+line = (element whitespace)+ (in-file)? whitespace (to-file | ap-file)? whitespace ("&")? => [[ first4 incantation boa ]]
+
+;EBNF
+
--- /dev/null
+
+USING: kernel words continuations namespaces debugger sequences combinators
+ system io io.files io.launcher sequences.deep
+ accessors multi-methods newfx shell.parser ;
+
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory [ first ] map ]
+ [ ]
+ if ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-incantation ( incantation -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-detached drop ]
+ [ [ try-process ] [ print-error drop ] recover ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( incantation -- )
+ dup command>> first swords member-of?
+ [ command>> unclip "shell" lookup execute ]
+ [ run-incantation ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr ast>> chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
\ No newline at end of file
"220 OK\r\n" write flush t
] }
{ [ data-mode get ] [ dup global [ print ] bind t ] }
- { [ t ] [
+ [
"500 ERROR\r\n" write flush t
- ] }
+ ]
} cond nip [ process ] when ;
: mock-smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> ascii <server> [
- accept [
+ accept drop [
1 minutes stdio get set-timeout
"220 hello\r\n" write flush
process
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii
-calendar.format accessors ;
+calendar.format accessors sets ;
IN: smtp
SYMBOL: smtp-domain
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" seq-intersect empty?
+ dup "\r\n>" intersect empty?
[ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
- { [ t ] [ "unknown error" throw ] }
+ [ "unknown error" throw ]
} cond ;
: multiline? ( response -- boolean )
: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "Invalid header string: " prepend throw ] unless ;
: write-header ( key value -- )
message-id "Message-Id" set-header ;
: <email> ( -- email )
- email construct-empty
+ email new
H{ } clone >>headers ;
: send-email ( email -- )
{ [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
{ [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
{ [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
- { [ t ] [ 2drop white ] }
+ [ 2drop white ]
} cond ;
: plot-bitmap-bits ( bitmap point byte bit -- )
TUPLE: state place data ;
TUPLE: missing-state ;
-: missing-state \ missing-state construct-empty throw ;
+: missing-state \ missing-state new throw ;
M: missing-state error.
drop "Missing state" print ;
! * Errors\r
TUPLE: parsing-error line column ;\r
: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error construct-boa ;\r
+ get-line get-column parsing-error boa ;\r
\r
: construct-parsing-error ( ... slots class -- error )\r
construct <parsing-error> over set-delegate ; inline\r
#! advance spot to after the substring.\r
[ [\r
dup slip swap dup [ get-char , ] unless\r
- ] skip-until ] "" make nip ;\r
+ ] skip-until ] "" make nip ; inline\r
\r
: rest ( -- string )\r
[ f ] take-until ;\r
{ [ 3dup nip row-contains? ] [ 3drop ] }
{ [ 3dup drop col-contains? ] [ 3drop ] }
{ [ 3dup box-contains? ] [ 3drop ] }
- { [ t ] [ assume ] }
+ [ assume ]
} cond ;
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
{ [ 2dup board> ] [ >r 1+ r> search ] }
- { [ t ] [ solve ] }
+ [ solve ]
} cond ;
: sudoku ( board -- )
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
-hexdump io.encodings.binary ;
+hexdump io.encodings.binary inspector accessors ;
IN: tar
: zero-checksum 256 ;
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-: <tar-header> ( -- obj ) tar-header construct-empty ;
+: <tar-header> ( -- obj ) tar-header new ;
: tar-trim ( seq -- newseq )
[ "\0 " member? ] trim ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
2drop
- \ tar-header construct-empty
+ \ tar-header new
0 over set-tar-header-size
0 over set-tar-header-checksum
] [
[ read-tar-header ] with-string-reader
[ tar-header-checksum = [
- \ checksum-error construct-empty throw
+ \ checksum-error new throw
] unless
] keep
] if ;
-TUPLE: unknown-typeflag str ;
-: <unknown-typeflag> ( ch -- obj )
- 1string \ unknown-typeflag construct-boa ;
-
-TUPLE: unimplemented-typeflag header ;
-: <unimplemented-typeflag> ( header -- obj )
- global [ "Unimplemented typeflag: " print dup . flush ] bind
- tar-header-typeflag
- 1string \ unimplemented-typeflag construct-boa ;
+ERROR: unknown-typeflag ch ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> 1string
+ "Unknown typeflag: " prepend ;
: tar-append-path ( path -- newpath )
base-dir get prepend-path ;
! Normal file
: typeflag-0
- tar-header-name tar-append-path binary <file-writer>
+ name>> tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ;
! Hard link
-: typeflag-1 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink
-: typeflag-2 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-2 ( header -- ) unknown-typeflag ;
! character special
-: typeflag-3 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-3 ( header -- ) unknown-typeflag ;
! Block special
-: typeflag-4 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-4 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ;
! FIFO
-: typeflag-6 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-6 ( header -- ) unknown-typeflag ;
! Contiguous file
-: typeflag-7 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-7 ( header -- ) unknown-typeflag ;
! Global extended header
-: typeflag-8 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-8 ( header -- ) unknown-typeflag ;
! Extended header
-: typeflag-9 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header
-: typeflag-g ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-g ( header -- ) unknown-typeflag ;
! Extended POSIX header
-: typeflag-x ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-x ( header -- ) unknown-typeflag ;
! Solaris access control list
-: typeflag-A ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-A ( header -- ) unknown-typeflag ;
! GNU dumpdir
-: typeflag-D ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-D ( header -- ) unknown-typeflag ;
! Solaris extended attribute file
-: typeflag-E ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-E ( header -- ) unknown-typeflag ;
! Inode metadata
-: typeflag-I ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-I ( header -- ) unknown-typeflag ;
! Long link name
-: typeflag-K ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-K ( header -- ) unknown-typeflag ;
! Long file name
: typeflag-L ( header -- )
filename get tar-append-path make-directories ;
! Multi volume continuation entry
-: typeflag-M ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-M ( header -- ) unknown-typeflag ;
! GNU long file name
-: typeflag-N ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-N ( header -- ) unknown-typeflag ;
! Sparse file
-: typeflag-S ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-S ( header -- ) unknown-typeflag ;
! Volume header
-: typeflag-V ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-V ( header -- ) unknown-typeflag ;
! Vendor extended header type
-: typeflag-X ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
512 read
{ CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] }
- [ <unknown-typeflag> throw ]
+ [ unknown-typeflag ]
} case
! dup tar-header-size zero? [
! out-stream get [ dispose ] when
: parse-tar ( path -- obj )
binary [
- "tar-test" resource-path base-dir set
+ "resource:tar-test" base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
TUPLE: tax-table single married ;
: <tax-table> ( single married class -- obj )
- >r tax-table construct-boa r> construct-delegate ;
+ >r tax-table boa r> construct-delegate ;
: tax-bracket-range dup second swap first - ;
[ drop f <array> ] with map ;
: <board> ( width height -- board )
- 2dup make-rows board construct-boa ;
+ 2dup make-rows board boa ;
#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units
-namespaces assocs tools.walker ;
+namespaces assocs tools.walker generic ;
IN: tools.annotations
-: reset ( word -- )
+GENERIC: reset ( word -- )
+
+M: generic reset
+ [ call-next-method ]
+ [ subwords [ reset ] each ] bi ;
+
+M: word reset
dup "unannotated-def" word-prop [
[
dup dup "unannotated-def" word-prop define
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
+GENERIC# annotate-methods 1 ( word quot -- )
+
+M: generic annotate-methods
+ >r "methods" word-prop values r> [ annotate ] curry each ;
+
+M: word annotate-methods
+ annotate ;
+
: breakpoint ( word -- )
- [ add-breakpoint ] annotate ;
+ [ add-breakpoint ] annotate-methods ;
: breakpoint-if ( word quot -- )
- [ [ [ break ] when ] rot 3append ] curry annotate ;
+ [ [ [ break ] when ] rot 3append ] curry annotate-methods ;
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
- { [ t ] [ 2drop 1 ] }
+ [ 2drop 1 ]
} cond ;
: score ( full fuzzy -- n )
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
+
+: copy-vm ( executable bundle-name extension -- vm )
+ [ prepend-path ] dip append vm over copy-file ;
+
+: copy-fonts ( name dir -- )
+ append-path "fonts/" resource-path swap copy-tree-into ;
+
+: image-name ( vocab bundle-name -- str )
+ prepend-path ".image" append ;
: (copy-lines) ( stream -- )
dup stream-readln dup
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
- utf8 <process-stream>
- dup copy-lines
- process>> wait-for-process zero? [
+ utf8 <process-stream*>
+ >r copy-lines r> wait-for-process zero? [
"Deployment failed" throw
] unless ;
{ deploy-c-types? f }
! default value for deploy.macosx
{ "stop-after-last-window?" t }
- } union ;
+ } assoc-union ;
: deploy-config-path ( vocab -- string )
vocab-dir "deploy.factor" append-path ;
: deploy-config ( vocab -- assoc )
dup default-config swap
dup deploy-config-path vocab-file-contents
- parse-fresh dup empty? [ drop ] [ first union ] if ;
+ parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
$nl
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
{ $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
+{ $list
+ { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+ { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+ { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+}
+"In all cases, running the program displays a window with a message."
$nl
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
$nl
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
tools.deploy.backend math sequences io.launcher arrays\r
-namespaces continuations layouts ;\r
+namespaces continuations layouts accessors ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
] with-directory ;\r
\r
: small-enough? ( n -- ? )\r
- >r "test.image" temp-file file-info file-info-size r> <= ;\r
+ >r "test.image" temp-file file-info size>> r> <= ;\r
\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- 1500000 small-enough?\r
+ cell 8 = 30 15 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
] unit-test\r
\r
[ t ] [\r
- 2000000 small-enough?\r
+ cell 8 = 40 20 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- 3000000 small-enough?\r
+ cell 8 = 50 30 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [\r
os macosx? [ "tools.deploy.macosx" require ] when
os winnt? [ "tools.deploy.windows" require ] when
+os unix? [ "tools.deploy.unix" require ] when
\ No newline at end of file
USING: io io.files kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
-cocoa.application cocoa.classes cocoa.plists qualified ;
+io.backend cocoa.application cocoa.classes cocoa.plists
+qualified ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
bundle-dir over append-path -rot
"Contents" prepend-path append-path copy-tree ;
-: copy-vm ( executable bundle-name -- vm )
- "Contents/MacOS/" append-path prepend-path vm over copy-file ;
-
-: copy-fonts ( name -- )
- "fonts/" resource-path
- swap "Contents/Resources/" append-path copy-tree-into ;
-
-: app-plist ( executable bundle-name -- string )
+: app-plist ( executable bundle-name -- assoc )
[
- namespace {
- { "CFBundleInfoDictionaryVersion" "6.0" }
- { "CFBundlePackageType" "APPL" }
- } update
+ "6.0" "CFBundleInfoDictionaryVersion" set
+ "APPL" "CFBundlePackageType" set
file-name "CFBundleName" set
- dup "CFBundleExecutable" set
- "org.factor." prepend "CFBundleIdentifier" set
- ] H{ } make-assoc plist>string ;
+ [ "CFBundleExecutable" set ]
+ [ "org.factor." prepend "CFBundleIdentifier" set ] bi
+ ] H{ } make-assoc ;
-: create-app-plist ( vocab bundle-name -- )
+: create-app-plist ( executable bundle-name -- )
[ app-plist ] keep
"Contents/Info.plist" append-path
- utf8 set-file-contents ;
+ write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
dup "Frameworks" copy-bundle-dir
dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
- dup copy-fonts
- 2dup create-app-plist copy-vm ;
+ dup "Contents/Resources/" copy-fonts
+ 2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ;
: deploy.app-image ( vocab bundle-name -- str )
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
- bundle-name show-in-finder
+ bundle-name normalize-path show-in-finder
] bind
] with-directory ;
USING: qualified io.streams.c init fry namespaces assocs kernel
parser tools.deploy.config vocabs sequences words words.private
memory kernel.private continuations io prettyprint
-vocabs.loader debugger system strings ;
+vocabs.loader debugger system strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
+QUALIFIED: command-line
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.units
QUALIFIED: continuations
set-global ;
: strip-vocab-globals ( except names -- words )
- [ child-vocabs [ words ] map concat ] map concat seq-diff ;
+ [ child-vocabs [ words ] map concat ] map concat diff ;
: stripped-globals ( -- seq )
[
{ } { "cpu" } strip-vocab-globals %
{
+ gensym
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
classes:class<-cache
classes:classes-intersect-cache
classes:update-map
+ command-line:main-vocab-hook
compiled-crossref
compiler.units:recompile-hook
+ compiler.units:update-tuples-hook
definitions:crossref
interactive-vocabs
layouts:num-tags
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
+
+ "<computer>" "inference.dataflow" lookup [ , ] when*
+
+ "windows-messages" "windows.messages" lookup [ , ] when*
+
] { } make ;
: strip-globals ( stripped-globals -- )
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
! Only keeps those methods that we actually call
- sent-messages get super-sent-messages get union
- objc-methods [ intersect ] change
+ sent-messages get super-sent-messages get assoc-union
+ objc-methods [ assoc-intersect ] change
sent-messages get
super-sent-messages get
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
- super-message-senders [ intersect ] change
- message-senders [ intersect ] change
+ super-message-senders [ assoc-intersect ] change
+ message-senders [ assoc-intersect ] change
sent-messages off
super-sent-messages off
--- /dev/null
+James Cash
--- /dev/null
+Deploying minimal stand-alone binaries on *nix-like systems
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
+IN: tools.deploy.linux
+
+: create-app-dir ( vocab bundle-name -- vm )
+ dup "" copy-fonts
+ "" copy-vm ;
+
+: bundle-name ( -- str )
+ deploy-name get ;
+
+M: linux deploy* ( vocab -- )
+ "." resource-path [
+ dup deploy-config [
+ [ bundle-name create-app-dir ] keep
+ [ bundle-name image-name ] keep
+ namespace make-deploy-image
+ bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+ ] bind
+ ] with-directory ;
\ No newline at end of file
prettyprint windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-vm ( executable bundle-name -- vm )
- prepend-path ".exe" append
- vm over copy-file ;
-
-: copy-fonts ( bundle-name -- )
- "fonts/" resource-path swap copy-tree-into ;
-
: copy-dlls ( bundle-name -- )
{ "freetype6.dll" "zlib1.dll" "factor.dll" }
[ resource-path ] map
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
- dup copy-fonts
- copy-vm ;
-
-: image-name ( vocab bundle-name -- str )
- prepend-path ".image" append ;
+ dup "" copy-fonts
+ ".exe" copy-vm ;
M: winnt deploy*
"." resource-path [
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
- open-in-explorer
+ (normalize-path) open-in-explorer
] bind
] with-directory ;
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
-: gdb-binary ( -- string )
- os freebsd? "gdb66" "gdb" ? ;
+: gdb-binary ( -- string ) "gdb" ;
: run-gdb ( -- lines )
<process>
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
-{ $subsection data-gc }
-{ $subsection code-gc }
+{ $subsection gc }
{ $see-also "images" } ;
ABOUT: "tools.memory"
USING: tools.test tools.memory ;
IN: tools.memory.tests
+\ room. must-infer
+[ ] [ room. ] unit-test
+
+\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
-system sorting splitting math.parser classes memory ;
+system sorting splitting math.parser classes memory combinators ;
IN: tools.memory
+<PRIVATE
+
+: write-size ( n -- )
+ number>string
+ dup length 4 > [ 3 cut* "," swap 3append ] when
+ " KB" append write-cell ;
+
: write-total/used/free ( free total str -- )
[
write-cell
- dup number>string write-cell
- over - number>string write-cell
- number>string write-cell
+ dup write-size
+ over - write-size
+ write-size
] with-row ;
: write-total ( n str -- )
[
write-cell
- number>string write-cell
+ write-size
[ ] with-cell
[ ] with-cell
] with-row ;
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
- data-room 2 <groups> 0 [
- "Generation " pick number>string append
- >r first2 r> write-total/used/free 1+
- ] reduce drop
+ data-room 2 <groups> dup length [
+ [ first2 ] [ number>string "Generation " prepend ] bi*
+ write-total/used/free
+ ] 2each
"Cards" write-total ;
+: write-labelled-size ( n string -- )
+ [ write-cell write-size ] with-row ;
+
: (code-room.) ( -- )
- code-room "Code space" write-total/used/free ;
+ code-room {
+ [ "Size:" write-labelled-size ]
+ [ "Used:" write-labelled-size ]
+ [ "Total free space:" write-labelled-size ]
+ [ "Largest free block:" write-labelled-size ]
+ } spread ;
+
+: heap-stat-step ( counts sizes obj -- )
+ [ dup size swap class rot at+ ] keep
+ 1 swap class rot at+ ;
+
+PRIVATE>
: room. ( -- )
+ "==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
+ ] tabular-output
+ nl
+ "==== CODE HEAP" print
+ standard-table-style [
(code-room.)
] tabular-output ;
-: heap-stat-step ( counts sizes obj -- )
- [ dup size swap class rot at+ ] keep
- 1 swap class rot at+ ;
-
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;
\ length profile-counter =
] unit-test
-[ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
+[ ] [ [ 10 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000 sleep ] profile ] unit-test
: threads. ( -- )\r
standard-table-style [\r
[\r
- { "ID" "Name" "Waiting on" "Remaining sleep" }\r
+ { "ID:" "Name:" "Waiting on:" "Remaining sleep:" }\r
[ [ write ] with-cell ] each\r
] with-row\r
\r
{
{ [ dup not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
- { [ t ] [ drop "[Loaded]" ] }
+ [ drop "[Loaded]" ]
} cond ;
: write-status ( vocab -- )
: describe-help ( vocab -- )
vocab-help [
- "Documentation" $heading nl ($link)
+ "Documentation" $heading ($link)
] when* ;
: describe-children ( vocab -- )
--- /dev/null
+USING: tools.test tools.vocabs.monitor io.files ;
+IN: tools.vocabs.monitor.tests
+
+[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads io.files io.monitors init kernel\r
-vocabs.loader tools.vocabs namespaces continuations ;\r
+vocabs vocabs.loader tools.vocabs namespaces continuations\r
+sequences splitting assocs command-line ;\r
IN: tools.vocabs.monitor\r
\r
-! Use file system change monitoring to flush the tags/authors\r
-! cache\r
-SYMBOL: vocab-monitor\r
+: vocab-dir>vocab-name ( path -- vocab )\r
+ left-trim-separators right-trim-separators\r
+ { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;\r
+\r
+: path>vocab-name ( path -- vocab )\r
+ dup ".factor" tail? [ parent-directory ] when ;\r
+\r
+: chop-vocab-root ( path -- path' )\r
+ "resource:" prepend-path (normalize-path)\r
+ dup vocab-roots get\r
+ [ (normalize-path) ] map\r
+ [ head? ] with find nip\r
+ ?head drop ;\r
+\r
+: path>vocab ( path -- vocab )\r
+ chop-vocab-root path>vocab-name vocab-dir>vocab-name ;\r
+\r
+: monitor-loop ( monitor -- )\r
+ #! On OS X, monitors give us the full path, so we chop it\r
+ #! off if its there.\r
+ dup next-change drop path>vocab changed-vocab\r
+ reset-cache\r
+ monitor-loop ;\r
\r
: monitor-thread ( -- )\r
- vocab-monitor get-global\r
- next-change 2drop\r
- t sources-changed? set-global reset-cache ;\r
+ [\r
+ [\r
+ "" resource-path t <monitor>\r
+ \r
+ H{ } clone changed-vocabs set-global\r
+ vocabs [ changed-vocab ] each\r
+ \r
+ monitor-loop\r
+ ] with-monitors\r
+ ] ignore-errors ;\r
\r
-: start-monitor-thread\r
+: start-monitor-thread ( -- )\r
#! Silently ignore errors during monitor creation since\r
#! monitors are not supported on all platforms.\r
- [\r
- "" resource-path t <monitor> vocab-monitor set-global\r
- [ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
- ] ignore-errors ;\r
+ [ monitor-thread ] "Vocabulary monitor" spawn drop ;\r
\r
-[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook\r
+[\r
+ "-no-monitors" cli-args member? [\r
+ start-monitor-thread\r
+ ] unless\r
+] "tools.vocabs.monitor" add-init-hook\r
--- /dev/null
+IN: tools.vocabs.tests
+USING: tools.test tools.vocabs namespaces continuations ;
+
+[ ] [
+ changed-vocabs get-global
+ f changed-vocabs set-global
+ [ t ] [ "kernel" changed-vocab? ] unit-test
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs\r
sequences namespaces math.parser arrays hashtables assocs\r
memoize inspector sorting splitting combinators source-files\r
-io debugger continuations compiler.errors init io.crc32 ;\r
+io debugger continuations compiler.errors init io.crc32 \r
+sets ;\r
IN: tools.vocabs\r
\r
: vocab-tests-file ( vocab -- path )\r
\r
: vocab-tests ( vocab -- tests )\r
[\r
- dup vocab-tests-file [ , ] when*\r
- vocab-tests-dir [ % ] when*\r
+ [ vocab-tests-file [ , ] when* ]\r
+ [ vocab-tests-dir [ % ] when* ] bi\r
] { } make ;\r
\r
: vocab-files ( vocab -- seq )\r
[\r
- dup vocab-source-path [ , ] when*\r
- dup vocab-docs-path [ , ] when*\r
- vocab-tests %\r
+ [ vocab-source-path [ , ] when* ]\r
+ [ vocab-docs-path [ , ] when* ]\r
+ [ vocab-tests % ] tri\r
] { } make ;\r
\r
-: source-modified? ( path -- ? )\r
- dup source-files get at [\r
- dup source-file-path\r
- dup exists? [\r
- utf8 file-lines lines-crc32\r
- swap source-file-checksum = not\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- exists?\r
- ] ?if ;\r
-\r
-: modified ( seq quot -- seq )\r
- [ dup ] swap compose { } map>assoc\r
- [ nip ] assoc-subset\r
- [ nip source-modified? ] assoc-subset keys ; inline\r
-\r
-: modified-sources ( vocabs -- seq )\r
- [ vocab-source-path ] modified ;\r
-\r
-: modified-docs ( vocabs -- seq )\r
- [ vocab-docs-path ] modified ;\r
-\r
-: to-refresh ( prefix -- modified-sources modified-docs )\r
- child-vocabs\r
- dup modified-sources swap modified-docs ;\r
-\r
: vocab-heading. ( vocab -- )\r
nl\r
"==== " write\r
- dup vocab-name swap vocab write-object ":" print\r
+ [ vocab-name ] [ vocab write-object ] bi ":" print\r
nl ;\r
\r
: load-error. ( triple -- )\r
- dup first vocab-heading.\r
- dup second print-error\r
- drop ;\r
+ [ first vocab-heading. ] [ second print-error ] bi ;\r
\r
: load-failures. ( failures -- )\r
[ load-error. nl ] each ;\r
failures get\r
] with-compiler-errors ;\r
\r
-: do-refresh ( modified-sources modified-docs -- )\r
- 2dup\r
- [ f swap set-vocab-docs-loaded? ] each\r
- [ f swap set-vocab-source-loaded? ] each\r
- append prune require-all load-failures. ;\r
+: source-modified? ( path -- ? )\r
+ dup source-files get at [\r
+ dup source-file-path\r
+ dup exists? [\r
+ utf8 file-lines lines-crc32\r
+ swap source-file-checksum = not\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ exists?\r
+ ] ?if ;\r
\r
-: refresh ( prefix -- ) to-refresh do-refresh ;\r
+SYMBOL: changed-vocabs\r
+\r
+[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
\r
-SYMBOL: sources-changed?\r
+: changed-vocab ( vocab -- )\r
+ dup vocab changed-vocabs get and\r
+ [ dup changed-vocabs get set-at ] [ drop ] if ;\r
\r
-[ t sources-changed? set-global ] "tools.vocabs" add-init-hook\r
+: unchanged-vocab ( vocab -- )\r
+ changed-vocabs get delete-at ;\r
\r
-: refresh-all ( -- )\r
- "" refresh f sources-changed? set-global ;\r
+: unchanged-vocabs ( vocabs -- )\r
+ [ unchanged-vocab ] each ;\r
+\r
+: changed-vocab? ( vocab -- ? )\r
+ changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
+\r
+: filter-changed ( vocabs -- vocabs' )\r
+ [ changed-vocab? ] subset ;\r
+\r
+SYMBOL: modified-sources\r
+SYMBOL: modified-docs\r
+\r
+: (to-refresh) ( vocab variable loaded? path -- )\r
+ dup [\r
+ swap [\r
+ pick changed-vocab? [\r
+ source-modified? [ get push ] [ 2drop ] if\r
+ ] [ 3drop ] if\r
+ ] [ drop get push ] if\r
+ ] [ 2drop 2drop ] if ;\r
+\r
+: to-refresh ( prefix -- modified-sources modified-docs unchanged )\r
+ [\r
+ V{ } clone modified-sources set\r
+ V{ } clone modified-docs set\r
+\r
+ child-vocabs [\r
+ [\r
+ [\r
+ [ modified-sources ]\r
+ [ vocab-source-loaded? ]\r
+ [ vocab-source-path ]\r
+ tri (to-refresh)\r
+ ] [\r
+ [ modified-docs ]\r
+ [ vocab-docs-loaded? ]\r
+ [ vocab-docs-path ]\r
+ tri (to-refresh)\r
+ ] bi\r
+ ] each\r
+\r
+ modified-sources get\r
+ modified-docs get\r
+ ]\r
+ [ modified-sources get modified-docs get append swap diff ] bi\r
+ ] with-scope ;\r
+\r
+: do-refresh ( modified-sources modified-docs unchanged -- )\r
+ unchanged-vocabs\r
+ [\r
+ [ [ f swap set-vocab-source-loaded? ] each ]\r
+ [ [ f swap set-vocab-docs-loaded? ] each ] bi*\r
+ ]\r
+ [\r
+ append prune\r
+ [ unchanged-vocabs ]\r
+ [ require-all load-failures. ] bi\r
+ ] 2bi ;\r
+\r
+: refresh ( prefix -- ) to-refresh do-refresh ;\r
\r
-MEMO: (vocab-file-contents) ( path -- lines )\r
- dup exists? [ utf8 file-lines ] [ drop f ] if ;\r
+: refresh-all ( -- ) "" refresh ;\r
\r
-: vocab-file-contents ( vocab name -- seq )\r
- vocab-append-path dup [ (vocab-file-contents) ] when ;\r
+MEMO: vocab-file-contents ( vocab name -- seq )\r
+ vocab-append-path dup\r
+ [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;\r
\r
: set-vocab-file-contents ( seq vocab name -- )\r
dupd vocab-append-path [\r
utf8 set-file-lines\r
- \ (vocab-file-contents) reset-memoized\r
+ \ vocab-file-contents reset-memoized\r
] [\r
"The " swap vocab-name\r
" vocabulary was not loaded from the file system"\r
{ [ ".test" ?tail ] [ t ] }\r
{ [ "raptor" ?head ] [ t ] }\r
{ [ dup "tools.deploy.app" = ] [ t ] }\r
- { [ t ] [ f ] }\r
+ [ f ]\r
} cond nip ;\r
\r
: filter-dangerous ( seq -- seq' )\r
\r
: reset-cache ( -- )\r
root-cache get-global clear-assoc\r
- \ (vocab-file-contents) reset-memoized\r
+ \ vocab-file-contents reset-memoized\r
\ all-vocabs-seq reset-memoized\r
\ all-authors reset-memoized\r
\ all-tags reset-memoized ;\r
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models arrays accessors ;
+sequences.private assocs models arrays accessors
+generic generic.standard ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
: (step-into-dispatch) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
- dup "step-into" word-prop [
- call
- ] [
- dup primitive? [
- execute break
- ] [
- word-def (step-into-quot)
- ] if
- ] ?if ;
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup primitive? ] [ execute break ] }
+ [ word-def (step-into-quot) ]
+ } cond ;
\ (step-into-execute) t "step-into?" set-word-prop
>n ndrop >c c>
continue continue-with
stop yield suspend sleep (spawn)
- suspend
} [
dup [ execute break ] curry
"step-into" set-word-prop
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- { [ t ] [ , \ break , ] }
+ [ , \ break , ]
} cond %
] [ ] make
] change-frame ;
TUPLE: avl-node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node construct-boa tuck set-delegate ;
+ swap <node> 0 avl-node boa tuck set-delegate ;
: change-balance ( node amount -- )
over avl-node-balance + swap set-avl-node-balance ;
avl-node-balance {
{ [ dup zero? ] [ 2drop 0 0 ] }
{ [ over = ] [ neg 0 ] }
- { [ t ] [ 0 swap ] }
+ [ 0 swap ]
} cond ;
: double-rotate ( node -- node )
current-side get over avl-node-balance {
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
{ [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- { [ t ] [ dupd neg change-balance rebalance-delete ] }
+ [ dupd neg change-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
--- /dev/null
+collections
2dup get-splay [ 2nip set-node-value ] [
drop dup inc-count
2dup splay-split rot
- >r >r swapd r> node construct-boa r> set-tree-root
+ >r >r swapd r> node boa r> set-tree-root
] if ;
: new-root ( value key tree -- )
-Splay Trees
+Splay trees
TUPLE: tree root count ;
: <tree> ( -- tree )
- f 0 tree construct-boa ;
+ f 0 tree boa ;
: construct-tree ( class -- tree )
- construct-empty <tree> over set-delegate ; inline
+ new <tree> over set-delegate ; inline
INSTANCE: tree tree-mixin
TUPLE: node key value left right ;
: <node> ( key value -- node )
- f f node construct-boa ;
+ f f node boa ;
SYMBOL: current-side
[ 2drop t ] }
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
[ drop [ node-key ] keep node-value t ] }
- { [ t ] [ >r node-right r> find-node ] }
+ [ >r node-right r> find-node ]
} cond ; inline
M: tree-mixin assoc-find ( tree quot -- key value ? )
swap tuple>array length over length - ;
: <tuple-array> ( length example -- tuple-array )
- prepare-example [ rot * { } new ] keep
+ prepare-example [ rot * { } new-sequence ] keep
<sliced-groups> tuple-array construct-delegate
[ set-tuple-array-example ] keep ;
tuck >r >r tuple-array-example deconstruct r> r>
delegate set-nth ;
-M: tuple-array new tuple-array-example >tuple <tuple-array> ;
+M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq )
dup empty? [
[ scan-object pick rot set-slot parse-slots ] when* ;
: TUPLE{
- scan-word construct-empty parse-slots parsed ; parsing
+ scan-word new parse-slots parsed ; parsing
TUPLE: turtle ;
: <turtle> ( -- turtle )
-turtle construct-empty
+turtle new
{ 0 0 0 } clone <pos>
3 identity-matrix <ori>
rot
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard construct-boa ;
+: <clipboard> "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
-threads ;
+threads combinators ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
[ [ nip T{ select-all-action } send-action$ ] ui-try ]
}
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
{ "acceptsFirstResponder" "bool" { "id" "SEL" }
[ 2drop 1 ]
}
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- default-flags swap union >r word-props r> update ;
+ default-flags swap assoc-union >r word-props r> update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
TUPLE: border size fill ;
: <border> ( child gap -- border )
- dup 2array { 0 0 } border construct-boa
+ dup 2array { 0 0 } border boa
<gadget> over set-delegate
tuck add-gadget ;
} set-gestures
: <button> ( gadget quot -- button )
- button construct-empty
+ button new
[ set-button-quot ] keep
[ set-gadget-delegate ] keep ;
{ [ dup button-pressed? ] [ drop button-paint-pressed ] }
{ [ dup button-selected? ] [ drop button-paint-selected ] }
{ [ dup button-rollover? ] [ drop button-paint-rollover ] }
- { [ t ] [ drop button-paint-plain ] }
+ [ drop button-paint-plain ]
} cond ;
M: button-paint draw-interior
: <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
- repeat-button construct-empty
+ repeat-button new
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ;
--- /dev/null
+
+USING: kernel alien.c-types combinators sequences splitting
+ opengl.gl ui.gadgets ui.render
+ math math.vectors accessors ;
+
+IN: ui.gadgets.frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <frame-buffer> ( -- frame-buffer )
+ frame-buffer construct-gadget
+ [ ] >>action
+ { 100 100 } >>dim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: read-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ >r
+ 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer graft* graft>> call ;
+M: frame-buffer ungraft* ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: copy-row ( old new -- )
+ 2dup min-length swap >r head-slice 0 r> copy ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ group ] 2bi@
+! [ copy-row ] 2each ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ 16 * group ] 2bi@
+! [ copy-row ] 2each ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer layout* ( fb -- )
+ {
+ {
+ [ dup last-dim>> f = ]
+ [
+ init-frame-buffer-pixels
+ dup
+ rect-dim >>last-dim
+ drop
+ ]
+ }
+ {
+ [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ dup [ pixels>> ] [ last-dim>> first ] bi
+
+ rot init-frame-buffer-pixels
+ dup rect-dim >>last-dim
+
+ [ pixels>> ] [ rect-dim first ] bi
+
+ copy-pixels
+ ]
+ }
+ { [ t ] [ drop ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer draw-gadget* ( fb -- )
+
+ dup rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ draw-pixels
+
+ dup action>> call
+
+ glFlush
+
+ read-pixels
+
+ drop ;
+
: @bottom-right 2 2 ;
: <frame> ( -- frame )
- frame construct-empty
+ frame new
<frame-grid> <grid> over set-gadget-delegate ;
: (fill-center) ( vec n -- )
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel dlists math
+namespaces models kernel dlists math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
- 0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+ 0 0 mock-gadget boa <gadget> over set-delegate ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
: fast-children-on ( rect axis children -- from to )
3dup
>r >r dup rect-loc swap rect-dim v+
- r> r> (fast-children-on) [ 1+ ] [ 0 ] if*
+ r> r> (fast-children-on) ?1+
>r
>r >r rect-loc
r> r> (fast-children-on) 0 or
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup not ] [ 2drop f ] }
- { [ t ] [ gadget-parent child? ] }
+ [ gadget-parent child? ]
} cond ;
GENERIC: focusable-child* ( gadget -- child/t )
M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
- dup focusable-child swap request-focus-on ;
+ [ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq )
- [ gadget-parent ] follow ;
+ [ gadget-focus ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
- labelled-gadget construct-empty
+ labelled-gadget new
[
<label> dup reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
[ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget construct-empty
+ closable-gadget new
[
<title-bar> @top frame,
g-> set-closable-gadget-content @center frame,
IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
-kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting
-tools.test.ui models ;
+kernel sequences io io.styles io.streams.string tools.test
+prettyprint definitions help help.syntax help.markup
+help.stylesheet splitting tools.test.ui models math inspector ;
: #children "pane" get gadget-children length ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text
- dup make-pane gadget-text
- swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ;
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-ARTICLE: "test-article" "This is a test article"
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
selection-color swap set-pane-selection-color ;
: <pane> ( -- pane )
- pane construct-empty
+ pane new
<pile> over set-delegate
<shelf> over set-pane-prototype
<pile> <incremental> over add-output
dup gadget-children {
{ [ dup empty? ] [ 2drop "" <label> ] }
{ [ dup length 1 = ] [ nip first ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond ;
: smash-pane ( pane -- gadget ) pane-output smash-line ;
M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
! Character styles
dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button )
- presentation construct-empty
+ presentation new
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) ] }
- { [ t ] [ drop dup scroller-value swap scroll ] }
+ [ drop dup scroller-value swap scroll ]
} cond ;
M: scroller layout*
} define-command
: <slot-editor> ( ref -- gadget )
- slot-editor construct-empty
+ slot-editor new
[ set-slot-editor-ref ] keep
[
toolbar,
} set-gestures
: <editable-slot> ( gadget ref -- editable-slot )
- editable-slot construct-empty
+ editable-slot new
{ 1 0 } <track> over set-gadget-delegate
[ drop <gadget> ] over set-editable-slot-printer
[ set-editable-slot-ref ] keep
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets combinators.lib
-boxes
-calendar alarms symbols ;
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators sets ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
TUPLE: gain-focus ; C: <gain-focus> gain-focus
! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
+TUPLE: cut-action ; C: <cut-action> cut-action
+TUPLE: copy-action ; C: <copy-action> copy-action
+TUPLE: paste-action ; C: <paste-action> paste-action
+TUPLE: delete-action ; C: <delete-action> delete-action
+TUPLE: select-all-action ; C: <select-all-action> select-all-action
+
+TUPLE: left-action ; C: <left-action> left-action
+TUPLE: right-action ; C: <right-action> right-action
+TUPLE: up-action ; C: <up-action> up-action
+TUPLE: down-action ; C: <down-action> down-action
+
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
tuple>array 1 head* >tuple ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> construct-boa ; inline
+ >r [ S+ rot remove swap ] unless r> boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
: multi-click? ( button -- ? )
{
- [ multi-click-timeout? ]
- [ multi-click-button? ]
- [ multi-click-position? ]
- [ multi-click-position? ]
- } && nip ;
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ [ t ]
+ } cond nip ;
: update-click# ( button -- )
global [
button-down-# [ " " % # ] when*
] "" make ;
+M: left-action gesture>string drop "Swipe left" ;
+
+M: right-action gesture>string drop "Swipe right" ;
+
+M: up-action gesture>string drop "Swipe up" ;
+
+M: down-action gesture>string drop "Swipe down" ;
+
+M: zoom-in-action gesture>string drop "Zoom in" ;
+
+M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
+
M: object gesture>string drop f ;
: my-pprint pprint ;
-[ drop t ] \ my-pprint [ ] [ ] f operation construct-boa "op" set
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
[ [ 3 my-pprint ] ] [
3 "op" get operation-command command-quot
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
"op" set
[ "\"4\"" ] [
H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
: define-operation ( pred command flags -- )
- default-flags swap union
+ default-flags swap assoc-union
dupd define-command <operation>
operations get push ;
{
{ [ dup gadget-visible? not ] [ drop ] }
{ [ dup gadget-clipped? not ] [ (draw-gadget) ] }
- { [ t ] [ [ (draw-gadget) ] with-clipping ] }
+ [ [ (draw-gadget) ] with-clipping ]
} cond ;
! Pen paint properties
swap set-browser-gadget-history ;
: <browser-gadget> ( -- gadget )
- browser-gadget construct-empty
+ browser-gadget new
dup init-history [
toolbar,
g <help-pane> g-> set-browser-gadget-pane
{ T{ key-down f { A+ } "v" } com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
+
+browser-gadget "multi-touch" f {
+ { T{ left-action } com-back }
+ { T{ right-action } com-forward }
+} define-command-map
] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget )
- debugger construct-empty
+ debugger new
[
toolbar,
<restart-list> g-> set-debugger-restarts
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
- f deploy-gadget construct-boa [
+ f deploy-gadget boa [
dup <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] with-pane ;
: <inspector-gadget> ( -- gadget )
- inspector-gadget construct-empty
+ inspector-gadget new
[
toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
+inspector-gadget "multi-touch" f {
+ { T{ left-action } &back }
+} define-command-map
+
M: inspector-gadget tool-scroller
inspector-gadget-pane find-scroller ;
IN: ui.tools.interactor.tests
-USING: ui.tools.interactor tools.test ;
+USING: ui.tools.interactor ui.gadgets.panes namespaces
+ui.gadgets.editors concurrency.promises threads listener
+tools.test kernel calendar parser ;
-\ <interactor> must-infer
+[
+ \ <interactor> must-infer
+
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ "interactor" get stream-read-quot "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ ! This should not throw an exception
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
-sequences sequences.lib strings threads listener
+sequences strings threads listener
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace ;
+definitions boxes calendar concurrency.flags ui.tools.workspace
+accessors ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
] curry "input" suspend ;
M: interactor stream-readln
- [ interactor-yield ] keep interactor-finish ?first ;
+ [ interactor-yield ] keep interactor-finish
+ dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
stream-read ;
: go-to-error ( interactor error -- )
- dup parse-error-line 1- swap parse-error-col 2array
+ [ line>> 1- ] [ column>> ] bi 2array
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error delegate ] when
+ dup parse-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
drop parse-lines-interactive
] [
2nip
- dup delegate unexpected-eof? [ drop f ] when
+ dup parse-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
] recover ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
{ [ dup not ] [ drop "\n" swap user-input f f ] }
- { [ t ] [ handle-parse-error f f ] }
+ [ handle-parse-error f f ]
} cond ;
M: interactor stream-read-quot
[ interactor-yield ] keep {
{ [ over not ] [ drop ] }
{ [ over callable? ] [ drop ] }
- { [ t ] [
+ [
[ handle-interactive ] keep swap
[ interactor-finish ] [ nip stream-read-quot ] if
- ] }
+ ]
} cond ;
M: interactor pref-dim*
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads ;
+threads arrays generic ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
"listener" get [
[ "dup" ] [
- \ dup "listener" get word-completion-string
+ \ dup word-completion-string
] unit-test
- [ "USE: slots.private slot" ]
- [ \ slot "listener" get word-completion-string ] unit-test
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.streams.duplex io.styles
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
-math arrays ;
+math arrays generic accessors combinators ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
: <input-scroller> ( interactor -- scroller )
<scroller>
- input-scroller construct-empty
+ input-scroller new
[ set-gadget-delegate ] keep ;
M: input-scroller pref-dim*
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-: word-completion-string ( word listener -- string )
- >r dup word-name swap word-vocabulary dup vocab-words r>
- listener-gadget-input interactor-use memq?
- [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
+GENERIC: word-completion-string ( word -- string )
+
+M: word word-completion-string
+ word-name ;
+
+M: method-body word-completion-string
+ "method-generic" word-prop word-completion-string ;
+
+USE: generic.standard.engines.tuple
+
+M: engine-word word-completion-string
+ "engine-generic" word-prop word-completion-string ;
+
+: use-if-necessary ( word seq -- )
+ >r word-vocabulary vocab-words r>
+ {
+ { [ dup not ] [ 2drop ] }
+ { [ 2dup memq? ] [ 2drop ] }
+ [ push ]
+ } cond ;
: insert-word ( word -- )
- get-workspace
- workspace-listener
- [ word-completion-string ] keep
- listener-gadget-input user-input ;
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
: quot-action ( interactor -- lines )
dup control-value
TUPLE: stack-display ;
: <stack-display> ( -- gadget )
- stack-display construct-empty
+ stack-display new
g workspace-listener swap [
dup <toolbar> f track,
listener-gadget-stack [ stack. ]
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
- listener-gadget construct-empty dup init-listener
+ listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
: listener-help "ui-listener" help-window ;
TUPLE: profiler-gadget pane ;
: <profiler-gadget> ( -- gadget )
- profiler-gadget construct-empty
+ profiler-gadget new
[
toolbar,
<pane> g-> set-profiler-gadget-pane
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- live-search construct-empty
+ live-search new
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.operations
-ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ;
+ui.tools.interactor ui.tools.inspector ui.tools.listener
+ui.tools.operations ui.tools.profiler ui.tools.walker
+ui.tools.workspace vocabs ;
IN: ui.tools
ARTICLE: "ui-presentations" "Presentations in the UI"
$nl
"The slot editor has a toolbar containing various commands."
{ $command-map slot-editor "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
"The following commands are also available."
{ $command-map source-editor "word" } ;
ARTICLE: "ui-browser" "UI browser"
"The browser is used to display Factor code, documentation, and vocabularies."
{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "multi-touch" }
"Browsers are instances of " { $link browser-gadget } "." ;
ARTICLE: "ui-profiler" "UI profiler"
{ $command-map workspace "tool-switching" }
{ $command-map workspace "scrolling" }
{ $command-map workspace "workflow" }
+{ $command-map workspace "multi-touch" }
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;
{ T{ key-down f { A+ } "4" } com-profiler }
} define-command-map
+workspace "multi-touch" f {
+ { T{ zoom-out-action } com-listener }
+ { T{ up-action } refresh-all }
+} define-command-map
+
\ workspace-window
H{ { +nullary+ t } } define-command
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
- variables-gadget construct-empty
+ variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> f walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
- { [ t ] [ walker-gadget-thread eq? ] }
+ [ walker-gadget-thread eq? ]
} cond ;
: find-walker-window ( thread -- world/f )
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> gadget-children ?nth ;
-: make-node ( quot -- ) { } make node construct-boa , ; inline
+: make-node ( quot -- ) { } make node boa , ; inline
: traverse-to-path ( topath gadget -- )
dup not [
{ [ pick empty? ] [ rot drop traverse-to-path ] }
{ [ over empty? ] [ nip traverse-from-path ] }
{ [ pick first pick first = ] [ traverse-child ] }
- { [ t ] [ traverse-middle ] }
+ [ traverse-middle ]
} cond ;
: gadget-subtree ( frompath topath gadget -- seq )
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags ;
+hashtables concurrency.flags sets ;
IN: ui
! Assoc mapping aliens to gadgets
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols ;
+locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
+: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ >r 4dup r> 2nip nip
+ swap window set-world-active? DefWindowProc ;
+
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
- { [ t ] [
+ [
dup TranslateMessage drop
dup DispatchMessage drop
event-loop
- ] }
+ ]
} cond ;
: register-wndclassex ( -- class )
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
-io.encodings.utf8 combinators debugger system command-line
+io.encodings.utf8 combinators debugger command-line qualified
ui.render math.vectors classes.tuple opengl.gl threads ;
+QUALIFIED: system
IN: ui.x11
SINGLETON: x11-ui-backend
{
{ [ dup XA_PRIMARY = ] [ drop selection get ] }
{ [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
- { [ t ] [ drop <clipboard> ] }
+ [ drop <clipboard> ]
} cond ;
: encode-clipboard ( string type -- bytes )
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- { [ t ] [ drop send-notify-failure ] }
+ [ drop send-notify-failure ]
} cond ;
M: x11-ui-backend (close-window) ( handle -- )
x11-ui-backend ui-backend set-global
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" system:os-env "ui" "listener" ? ]
main-vocab-hook set-global
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-combinators.lib assocs.lib math.ranges unicode.normalize
+math.ranges unicode.normalize
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
} case ;
: trim-blank ( str -- newstr )
- dup [ blank? not ] find-last 1+* head ;
+ [ blank? ] right-trim ;
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] subset
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
- concat >set ;
+ concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path ascii file-lines ;
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ] [ other-extend key? ] either ;
+ dup (extend)? [ ] [ other-extend key? ] ?if ;
: grapheme-class ( ch -- class )
{
{ [ dup jamo? ] [ jamo-class ] }
{ [ dup grapheme-control? ] [ control-class ] }
{ [ extend? ] [ Extend ] }
- { [ t ] [ Any ] }
+ [ Any ]
} cond ;
: init-grapheme-table ( -- table )
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last-index
- nip -1 or 1+ ;
+ [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
[
other-extend-lines process-other-extend \ other-extend set-value
USING: kernel unicode.data sequences sequences.next namespaces
-assocs.lib unicode.normalize math unicode.categories combinators
+unicode.normalize math unicode.categories combinators
assocs strings splitting ;
IN: unicode.case
+: at-default ( key assoc -- value/key ) over >r at r> or ;
+
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
drop dot-over =
dup CHAR: i HEX: 131 ? ,
] }
- { [ t ] [ , drop f ] }
+ [ , drop f ]
} cond ;
: turk>lower ( string -- lower-i )
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser combinators.lib hash2
+quotations splitting arrays math.parser hash2
byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
IN: unicode.data
>>
! Convenience functions
-: 1+* ( n/f _ -- n+1 )
- drop [ 1+ ] [ 0 ] if* ;
-
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] either ;
+ second dup empty? [ ] [ first ] ?if ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
dup process-names \ name-map set-value
13 over process-data \ simple-lower set-value
12 over process-data tuck \ simple-upper set-value
-14 over process-data swapd union \ simple-title set-value
+14 over process-data swapd assoc-union \ simple-title set-value
dup process-combining \ class-map set-value
dup process-canonical \ canonical-map set-value
\ combine-map set-value
-USING: sequences namespaces unicode.data kernel combinators.lib
-math arrays ;
+USING: sequences namespaces unicode.data kernel math arrays ;
IN: unicode.normalize
! Conjoining Jamo behavior
! These numbers come from UAX 29
: initial? ( ch -- ? )
- [ HEX: 1100 HEX: 1159 ?between? ] [ HEX: 115F = ] either ;
+ dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
0 reorder-loop ;
: reorder-back ( string i -- )
- over [ non-starter? not ] find-last* 1+* reorder-next 2drop ;
+ over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be
USING: arrays io kernel math namespaces splitting prettyprint
sequences sorting vectors words inverse inspector shuffle
-math.functions ;
+math.functions sets ;
IN: units
TUPLE: dimensioned value top bot ;
TUPLE: dimensions-not-equal ;
: dimensions-not-equal ( -- * )
- \ dimensions-not-equal construct-empty throw ;
+ \ dimensions-not-equal new throw ;
M: dimensions-not-equal summary drop "Dimensions do not match" ;
[ remove-one ] curry bi@ ;
: symbolic-reduce ( seq seq -- seq seq )
- 2dup seq-intersect dup empty?
+ 2dup intersect dup empty?
[ drop ] [ first 2remove-one symbolic-reduce ] if ;
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
[ natural-sort ] bi@
- dimensioned construct-boa ;
+ dimensioned boa ;
: >dimensioned< ( d -- n top bot )
{ dimensioned-value dimensioned-top dimensioned-bot }
: S_IFMT OCT: 170000 ; ! These bits determine file type.
-: S_IFDIR OCT: 40000 ; ! Directory.
-: S_IFCHR OCT: 20000 ; ! Character device.
-: S_IFBLK OCT: 60000 ; ! Block device.
-: S_IFREG OCT: 100000 ; ! Regular file.
-: S_IFIFO OCT: 010000 ; ! FIFO.
-: S_IFLNK OCT: 120000 ; ! Symbolic link.
-: S_IFSOCK OCT: 140000 ; ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
+: S_IFDIR OCT: 40000 ; inline ! Directory.
+: S_IFCHR OCT: 20000 ; inline ! Character device.
+: S_IFBLK OCT: 60000 ; inline ! Block device.
+: S_IFREG OCT: 100000 ; inline ! Regular file.
+: S_IFIFO OCT: 010000 ; inline ! FIFO.
+: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
+: S_IFSOCK OCT: 140000 ; inline ! Socket.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Access Permissions
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
+: _exit ( status -- * )
+ #! We throw to give this a terminating stack effect.
+ "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
--- /dev/null
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+ builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+ image parent-directory
+ [
+ { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+ run-command
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+ "http://factorcode.org/images/clean/" my-boot-image-name append ;
+
+: download-clean-image ( -- ) { "wget" remote-clean-image } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make ( -- ) { gnu-make } run-command ;
+: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+ image parent-directory
+ [
+ download-clean-image
+ make-clean
+ make
+ boot
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+ image parent-directory
+ [
+ git-id
+ git-pull-clean
+ git-id
+ = not
+ [ rebuild ]
+ when
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update
\ No newline at end of file
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Item</t:title>
+
+ <t:form action="edit">
+ <t:edit component="id" />
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ <t:a href="view" query="id">View</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style>
+ body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+ }
+
+ a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+ }
+
+ a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+ }
+
+ .error { color: #a00; }
+
+ .field-label {
+ text-align: right;
+ }
+ </t:style>
+
+ <t:write-style />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>My Todo List</t:title>
+
+ <table class="todo-list">
+ <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
+ <t:view component="list" />
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <tr>
+ <td>
+ <t:view component="summary" />
+ </td>
+ <td>
+ <t:view component="priority" />
+ </td>
+ <td>
+ <t:a href="view" query="id">View</t:a>
+ </td>
+ <td>
+ <t:a href="edit" query="id">Edit</t:a>
+ </td>
+ </tr>
+
+</t:chloe>
--- /dev/null
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+ padding: 5px;
+ font-size: 150%;
+ color: #000000;
+}
+
+.link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+}
+
+.navbar {
+ background-color: #eeeeee;
+ padding: 5px;
+ border: 1px solid #ccc;
+}
+
+.inline {
+ display: inline;
+}
+
+pre {
+ font-size: 75%;
+}
+
+.todo-list {
+ border-style: none;
+}
+
+.todo-list td, .todo-list th {
+ border-width: 1px;
+ padding: 2px;
+ border-style: solid;
+}
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals sequences
+db db.types db.tuples
+http.server.components http.server.components.farkup
+http.server.forms http.server.templating.chloe
+http.server.boilerplate http.server.crud http.server.auth
+http.server.actions http.server.db
+http.server ;
+IN: webapps.todo
+
+TUPLE: todo uid id priority summary description ;
+
+todo "TODO"
+{
+ { "uid" "UID" { VARCHAR 256 } +not-null+ }
+ { "id" "ID" +native-id+ }
+ { "priority" "PRIORITY" INTEGER +not-null+ }
+ { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" { VARCHAR 256 } }
+} define-persistent
+
+: init-todo-table todo ensure-table ;
+
+: <todo> ( id -- todo )
+ todo new
+ swap >>id
+ uid >>uid ;
+
+: todo-template ( name -- template )
+ "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
+
+: <todo-form> ( -- form )
+ "todo" <form>
+ "view-todo" todo-template >>view-template
+ "edit-todo" todo-template >>edit-template
+ "todo-summary" todo-template >>summary-template
+ "id" <integer>
+ hidden >>renderer
+ add-field
+ "summary" <string>
+ t >>required
+ add-field
+ "priority" <integer>
+ t >>required
+ 0 >>default
+ 0 >>min-value
+ 10 >>max-value
+ add-field
+ "description" <farkup>
+ add-field ;
+
+: <todo-list-form> ( -- form )
+ "todo-list" <form>
+ "todo-list" todo-template >>view-template
+ "list" <todo-form> +plain+ <list>
+ add-field ;
+
+TUPLE: todo-responder < dispatcher ;
+
+:: <todo-responder> ( -- responder )
+ [let | todo-form [ <todo-form> ]
+ list-form [ <todo-list-form> ]
+ ctor [ [ <todo> ] ] |
+ todo-responder new-dispatcher
+ list-form ctor <list-action> "list" add-main-responder
+ todo-form ctor <view-action> "view" add-responder
+ todo-form ctor "view" <edit-action> "edit" add-responder
+ ctor "list" <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ ] ;
+
+! What follows below is somewhat akin to a 'deployment descriptor'
+! for the todo application. The <todo-responder> can be integrated
+! into an existing web app that provides session management and
+! login facilities, or <todo-app> can be used to run a
+! self-contained todo instance.
+USING: namespaces io.files io.sockets
+db.sqlite smtp
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+: <todo-app> ( -- responder )
+ <todo-responder>
+ <login>
+ users-in-db >>users
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ "page" todo-template >>template
+ <url-sessions>
+ sessions-in-db >>sessions
+ test-db <db-persistence> ;
+
+: init-todo ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+
+ test-db [
+ init-todo-table
+ init-users-table
+ init-sessions-table
+ ] with-db
+
+ <dispatcher>
+ <todo-app> "todo" add-responder
+ main-responder set-global ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style include="resource:extra/webapps/todo/todo.css" />
+
+ <t:style include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <div class="navbar">
+ <t:a href="list">List Items</t:a>
+ | <t:a href="edit">Add Item</t:a>
+
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
+
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>View Item</t:title>
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr>
+ </table>
+
+ <div class="description">
+ <t:view component="description" />
+ </div>
+
+ <t:a href="edit" query="id">Edit</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
: CRYPT_SILENT HEX: 40 ; inline
+C-STRUCT: ACL
+ { "BYTE" "AclRevision" }
+ { "BYTE" "Sbz1" }
+ { "WORD" "AclSize" }
+ { "WORD" "AceCount" }
+ { "WORD" "Sbz2" } ;
+
+TYPEDEF: ACL* PACL
+
+: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
+: ACCESS_DENIED_ACE_TYPE 1 ; inline
+: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
+: SYSTEM_ALARM_ACE_TYPE 3 ; inline
+
+: OBJECT_INHERIT_ACE HEX: 1 ; inline
+: CONTAINER_INHERIT_ACE HEX: 2 ; inline
+: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
+: INHERIT_ONLY_ACE HEX: 8 ; inline
+: VALID_INHERIT_FLAGS HEX: f ; inline
+
+C-STRUCT: ACE_HEADER
+ { "BYTE" "AceType" }
+ { "BYTE" "AceFlags" }
+ { "WORD" "AceSize" } ;
+
+TYPEDEF: ACE_HEADER* PACE_HEADER
+
+C-STRUCT: ACCESS_ALLOWED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
+
+C-STRUCT: ACCESS_DENIED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
+
+
+C-STRUCT: SYSTEM_AUDIT_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
+
+C-STRUCT: SYSTEM_ALARM_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
+
+C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+
+
+! typedef enum _TOKEN_INFORMATION_CLASS {
+: TokenUser 1 ; inline
+: TokenGroups 2 ; inline
+: TokenPrivileges 3 ; inline
+: TokenOwner 4 ; inline
+: TokenPrimaryGroup 5 ; inline
+: TokenDefaultDacl 6 ; inline
+: TokenSource 7 ; inline
+: TokenType 8 ; inline
+: TokenImpersonationLevel 9 ; inline
+: TokenStatistics 10 ; inline
+: TokenRestrictedSids 11 ; inline
+: TokenSessionId 12 ; inline
+: TokenGroupsAndPrivileges 13 ; inline
+: TokenSessionReference 14 ; inline
+: TokenSandBoxInert 15 ; inline
+! } TOKEN_INFORMATION_CLASS;
+
+: DELETE HEX: 00010000 ; inline
+: READ_CONTROL HEX: 00020000 ; inline
+: WRITE_DAC HEX: 00040000 ; inline
+: WRITE_OWNER HEX: 00080000 ; inline
+: SYNCHRONIZE HEX: 00100000 ; inline
+: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
+
+: STANDARD_RIGHTS_READ READ_CONTROL ; inline
+: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
+: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
+
+: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
+: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
+: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
+: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
+: TOKEN_DUPLICATE HEX: 0002 ; inline
+: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
+: TOKEN_IMPERSONATE HEX: 0004 ; inline
+: TOKEN_QUERY HEX: 0008 ; inline
+: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
+: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+
+: TOKEN_WRITE
+ {
+ STANDARD_RIGHTS_WRITE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
+: TOKEN_ALL_ACCESS
+ {
+ STANDARD_RIGHTS_REQUIRED
+ TOKEN_ASSIGN_PRIMARY
+ TOKEN_DUPLICATE
+ TOKEN_IMPERSONATE
+ TOKEN_QUERY
+ TOKEN_QUERY_SOURCE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_SESSIONID
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
! : AddAccessDeniedAce ;
! : AddAccessDeniedAceEx ;
! : AddAccessDeniedObjectAce ;
-! : AddAce ;
+FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
! : AddAuditAccessAce ;
! : AddAuditAccessAceEx ;
! : AddAuditAccessObjectAce ;
! : ImpersonateLoggedOnUser ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
-! : InitializeAcl ;
+FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : OpenEventLogA ;
! : OpenEventLogW ;
-! typedef enum _TOKEN_INFORMATION_CLASS {
-: TokenUser 1 ;
-: TokenGroups 2 ;
-: TokenPrivileges 3 ;
-: TokenOwner 4 ;
-: TokenPrimaryGroup 5 ;
-: TokenDefaultDacl 6 ;
-: TokenSource 7 ;
-: TokenType 8 ;
-: TokenImpersonationLevel 9 ;
-: TokenStatistics 10 ;
-: TokenRestrictedSids 11 ;
-: TokenSessionId 12 ;
-: TokenGroupsAndPrivileges 13 ;
-: TokenSessionReference 14 ;
-: TokenSandBoxInert 15 ;
-! } TOKEN_INFORMATION_CLASS;
-
-: DELETE HEX: 00010000 ; inline
-: READ_CONTROL HEX: 00020000 ; inline
-: WRITE_DAC HEX: 00040000 ; inline
-: WRITE_OWNER HEX: 00080000 ; inline
-: SYNCHRONIZE HEX: 00100000 ; inline
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
-
-: STANDARD_RIGHTS_READ READ_CONTROL ; inline
-: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
-: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
-
-: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
-: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
-: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
-: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
-: TOKEN_DUPLICATE HEX: 0002 ; inline
-: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
-: TOKEN_IMPERSONATE HEX: 0004 ; inline
-: TOKEN_QUERY HEX: 0008 ; inline
-: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
-: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
-
-: TOKEN_WRITE
- {
- STANDARD_RIGHTS_WRITE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
-: TOKEN_ALL_ACCESS
- {
- STANDARD_RIGHTS_REQUIRED
- TOKEN_ASSIGN_PRIMARY
- TOKEN_DUPLICATE
- TOKEN_IMPERSONATE
- TOKEN_QUERY
- TOKEN_QUERY_SOURCE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_SESSIONID
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle ) ;
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
: LM_SETITEM WM_USER HEX: 0302 + ; inline
: LM_GETITEM WM_USER HEX: 0303 + ; inline
+
+
+: WA_INACTIVE 0 ; inline
+: WA_ACTIVE 1 ; inline
+: WA_CLICKACTIVE 2 ; inline
+
+: SC_SIZE HEX: f000 ; inline
+: SC_MOVE HEX: f010 ; inline
+: SC_MINIMIZE HEX: f020 ; inline
+: SC_MAXIMIZE HEX: f030 ; inline
+: SC_NEXTWINDOW HEX: f040 ; inline
+: SC_PREVWINDOW HEX: f050 ; inline
+: SC_CLOSE HEX: f060 ; inline
+: SC_VSCROLL HEX: f070 ; inline
+: SC_HSCROLL HEX: f080 ; inline
+: SC_MOUSEMENU HEX: f090 ; inline
+: SC_KEYMENU HEX: f100 ; inline
+: SC_ARRANGE HEX: f110 ; inline
+: SC_RESTORE HEX: f120 ; inline
+: SC_TASKLIST HEX: f130 ; inline
+: SC_SCREENSAVE HEX: f140 ; inline
+: SC_HOTKEY HEX: f150 ; inline
TUPLE: x-clipboard atom contents ;
: <x-clipboard> ( atom -- clipboard )
- "" x-clipboard construct-boa ;
+ "" x-clipboard boa ;
: selection-property ( -- n )
"org.factorcode.Factor.SELECTION" x-atom ;
: handle-event ( event window -- )
over XAnyEvent-type {
- { [ dup Expose = ] [ drop expose-event ] }
- { [ dup ConfigureNotify = ] [ drop configure-event ] }
- { [ dup ButtonPress = ] [ drop button-down-event$ ] }
- { [ dup ButtonRelease = ] [ drop button-up-event$ ] }
- { [ dup EnterNotify = ] [ drop enter-event ] }
- { [ dup LeaveNotify = ] [ drop leave-event ] }
- { [ dup MotionNotify = ] [ drop motion-event ] }
- { [ dup KeyPress = ] [ drop key-down-event ] }
- { [ dup KeyRelease = ] [ drop key-up-event ] }
- { [ dup FocusIn = ] [ drop focus-in-event ] }
- { [ dup FocusOut = ] [ drop focus-out-event ] }
- { [ dup SelectionNotify = ] [ drop selection-notify-event ] }
- { [ dup SelectionRequest = ] [ drop selection-request-event ] }
- { [ dup ClientMessage = ] [ drop client-event ] }
- { [ t ] [ 3drop ] }
- } cond ;
+ { Expose [ expose-event ] }
+ { ConfigureNotify [ configure-event ] }
+ { ButtonPress [ button-down-event$ ] }
+ { ButtonRelease [ button-up-event$ ] }
+ { EnterNotify [ enter-event ] }
+ { LeaveNotify [ leave-event ] }
+ { MotionNotify [ motion-event ] }
+ { KeyPress [ key-down-event ] }
+ { KeyRelease [ key-up-event ] }
+ { FocusIn [ focus-in-event ] }
+ { FocusOut [ focus-out-event ] }
+ { SelectionNotify [ selection-notify-event ] }
+ { SelectionRequest [ selection-request-event ] }
+ { ClientMessage [ client-event ] }
+ [ 3drop ]
+ } case ;
: configured-loc ( event -- dim )
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
TUPLE: server-error tag message ;
: server-error ( tag message -- * )
- \ server-error construct-boa throw ;
+ \ server-error boa throw ;
M: server-error error.
"Error in XML supplied to server" print
dup children>string {
{ [ dup "1" = ] [ 2drop t ] }
{ [ "0" = ] [ drop f ] }
- { [ t ] [ "Bad boolean" server-error ] }
+ [ "Bad boolean" server-error ]
} cond ;
: unstruct-member ( tag -- )
] if* ;
M: attrs assoc-size attrs-alist length ;
-M: attrs new-assoc drop V{ } new <attrs> ;
+M: attrs new-assoc drop V{ } new
-sequence <attrs> ;
M: attrs >alist attrs-alist ;
: >attrs ( assoc -- attrs )
continuations assocs sequences.deep ;
! This is insufficient
+\ read-xml must-infer
+
SYMBOL: xml-file
[ ] [ "extra/xml/tests/test.xml" resource-path
[ file>xml ] with-html-entities xml-file set ] unit-test
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.errors xml.data xml.utilities xml.char-classes
+USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces strings math
math.parser sequences assocs arrays splitting combinators unicode.case ;
IN: xml.tokenize
{ [ dup not ] [ 2drop ] }
{ [ 2dup = ] [ 2drop next ] }
{ [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
- { [ t ] [ , next (parse-char) ] }
+ [ , next (parse-char) ]
} cond ;
: parse-char ( ch -- string )
T{ name f "" "version" f }
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
- } swap seq-diff
+ } swap diff
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
: good-version ( version -- version )
{
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
{ [ CHAR: ? = ] [ next instruct ] }
- { [ t ] [
+ [
start-tag [ dup add-ns pop-ns <closer> ]
[ middle-tag end-tag ] if
CHAR: > expect
- ] }
+ ]
} cond ;
: run-process ( tag word -- )
2dup "xtable" word-prop
>r dup name-tag r> at* [ 2nip call ] [
- drop \ process-missing construct-boa throw
+ drop \ process-missing boa throw
] if ;
: PROCESS:
! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
-io io.streams.string xml.data assocs wrap xml.entities\r
-unicode.categories ;\r
+assocs combinators io io.streams.string\r
+xml.data wrap xml.entities unicode.categories ;\r
IN: xml.writer\r
\r
SYMBOL: xml-pprint?\r
xml-pprint? get [ -1 indentation +@ ] when ;\r
\r
: trim-whitespace ( string -- no-whitespace )\r
- [ [ blank? not ] find drop 0 or ] keep\r
- [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep\r
- subseq ;\r
+ [ blank? ] trim ;\r
\r
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
?indent CHAR: < write1\r
dup print-name tag-attrs print-attrs ;\r
\r
+: write-start-tag ( tag -- )\r
+ write-tag ">" write ;\r
+\r
M: contained-tag write-item\r
write-tag "/>" write ;\r
\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
M: open-tag write-item\r
- xml-pprint? [ [\r
- over sensitive? not and xml-pprint? set\r
- dup write-tag CHAR: > write1\r
- dup write-children write-end-tag\r
- ] keep ] change ;\r
+ xml-pprint? get >r\r
+ {\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
+ [ write-start-tag ]\r
+ [ write-children ]\r
+ [ write-end-tag ]\r
+ } cleave\r
+ r> xml-pprint? set ;\r
\r
M: comment write-item\r
"<!--" write comment-text write "-->" write ;\r
[ write-item ] each ;\r
\r
: write-xml ( xml -- )\r
- dup xml-prolog write-prolog\r
- dup xml-before write-chunk\r
- dup write-item\r
- xml-after write-chunk ;\r
+ {\r
+ [ xml-prolog write-prolog ]\r
+ [ xml-before write-chunk ]\r
+ [ write-item ]\r
+ [ xml-after write-chunk ]\r
+ } cleave ;\r
\r
: print-xml ( xml -- )\r
write-xml nl ;\r
TAG: MODE
"NAME" over at >r
- mode construct-empty {
+ mode new {
{ "FILE" f set-mode-file }
{ "FILE_NAME_GLOB" f set-mode-file-name-glob }
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob }
f \ modes set-global ;
MEMO: (load-mode) ( name -- rule-sets )
- modes at mode-file
- "extra/xmode/modes/" prepend
- resource-path utf8 <file-reader> parse-mode ;
+ modes at [
+ mode-file
+ "extra/xmode/modes/" prepend
+ resource-path utf8 <file-reader> parse-mode
+ ] [
+ "text" (load-mode)
+ ] if* ;
SYMBOL: rule-sets
USING: kernel strings assocs sequences hashtables sorting
- unicode.case unicode.categories ;
+ unicode.case unicode.categories sets ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap
] keep ;
: merge-rule-set-props ( props rule-set -- )
- [ rule-set-props union ] keep set-rule-set-props ;
+ [ rule-set-props assoc-union ] keep set-rule-set-props ;
! Top-level entry points
: parse-mode-tag ( tag -- rule-sets )
} set-slots ;
: <rule-set> ( -- ruleset )
- rule-set construct-empty dup init-rule-set ;
+ rule-set new dup init-rule-set ;
MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ;
;
: construct-rule ( class -- rule )
- >r rule construct-empty r> construct-delegate ; inline
+ >r rule new r> construct-delegate ; inline
TUPLE: seq-rule ;
TUPLE: company employees type ;
-: <company> V{ } clone f company construct-boa ;
+: <company> V{ } clone f company boa ;
: add-employee company-employees push ;
TUPLE: employee name description ;
TAG: employee
- employee construct-empty
+ employee new
{ { "name" f set-employee-name } { f set-employee-description } }
init-from-tag swap add-employee ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1
+ [ "hi" print ] [ ] if ; ! when
+
+[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
+
+: lint2
+ 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3
+ dup -rot ; ! tuck
+
+[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays assocs combinators.lib io kernel
+macros math namespaces prettyprint quotations sequences
+vectors vocabs words html.elements slots.private tar ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot >r >r ?push r> r> set-at ;
+
+: add-word-def ( word quot -- )
+ dup callable? [
+ def-hash get-global set-hash-vector
+ ] [
+ 2drop
+ ] if ;
+
+: more-defs
+ {
+ { [ swap >r swap r> ] -rot }
+ { [ swap swapd ] -rot }
+ { [ >r swap r> swap ] rot }
+ { [ swapd swap ] rot }
+ { [ dup swap ] over }
+ { [ dup -rot ] tuck }
+ { [ >r swap r> ] swapd }
+ { [ nip nip ] 2nip }
+ { [ drop drop ] 2drop }
+ { [ drop drop drop ] 3drop }
+ { [ 0 = ] zero? }
+ { [ pop drop ] pop* }
+ { [ [ ] if ] when }
+ } [ first2 swap add-word-def ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs
+ {
+ [ get ] [ t ] [ { } ] [ . ] [ drop f ]
+ [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write-html ] [ <unimplemented-typeflag> throw ]
+ [ "/>" write-html ]
+ } ;
+
+H{ } clone def-hash set-global
+all-words [ dup word-def add-word-def ] each
+more-defs
+
+! Remove empty word defs
+def-hash get-global [
+ drop empty? not
+] assoc-subset
+
+! Remove constants [ 1 ]
+[
+ drop dup length 1 = swap first number? and not
+] assoc-subset
+
+! Remove set-alien-cell, etc.
+[
+ drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
+] assoc-subset
+
+! Remove trivial defs
+[
+ drop trivial-defs member? not
+] assoc-subset
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ dup first2 [ number? ] both?
+ swap third \ shift = and not
+ ] [ drop t ] if
+] assoc-subset
+
+! Remove [ n slot ]
+[
+ drop dup length 2 = [
+ first2 \ slot = swap number? and not
+ ] [ drop t ] if
+] assoc-subset def-hash set-global
+
+: find-duplicates
+ def-hash get-global [
+ nip length 1 >
+ ] assoc-subset ;
+
+def-hash get-global keys def-hash-keys set-global
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq )
+ drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+
+M: callable lint ( quot -- seq )
+ def-hash-keys get [
+ swap subseq/member?
+ ] with subset ;
+
+M: word lint ( word -- seq )
+ word-def dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ word-vocabulary ":" ] keep unparse 3append write nl ;
+
+: (lint.) ( pair -- )
+ first2 >r word-path. r> [
+ bl bl bl bl
+ dup .
+ "-----------------------------------" print
+ def-hash get at [ bl bl bl bl word-path. ] each
+ nl
+ ] each nl nl ;
+
+: lint. ( alist -- )
+ [ (lint.) ] each ;
+
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self)
+ def-hash get-global at* [
+ dupd remove empty? not
+ ] [
+ drop f
+ ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] subset ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get at
+ [ first ] bi@ literalize = not
+ ] assoc-subset ;
+
+M: sequence run-lint ( seq -- seq )
+ [
+ global [ dup . flush ] bind
+ dup lint
+ ] { } map>assoc
+ trim-self
+ [ second empty? not ] subset
+ filter-symbols ;
+
+M: word run-lint ( word -- seq )
+ 1array run-lint ;
+
+: lint-all ( -- seq )
+ all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+ words run-lint dup lint. ;
+
+: lint-word ( word -- seq )
+ 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math.constants ;
+IN: random-tester.databank
+
+: databank ( -- array )
+ {
+ ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
+ pi 1/0. -1/0. 0/0. [ ]
+ f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
+ C{ 2 2 } C{ 1/0. 1/0. }
+ } ;
+
--- /dev/null
+USING: compiler continuations io kernel math namespaces
+prettyprint quotations random sequences vectors
+compiler.units ;
+USING: random-tester.databank random-tester.safe-words ;
+IN: random-tester
+
+SYMBOL: errored
+SYMBOL: before
+SYMBOL: after
+SYMBOL: quot
+TUPLE: random-tester-error ;
+
+: setup-test ( #data #code -- data... quot )
+ #! Variable stack effect
+ >r [ databank random ] times r>
+ [ drop \ safe-words get random ] map >quotation ;
+
+: test-compiler ! ( data... quot -- ... )
+ errored off
+ dup quot set
+ datastack 1 head* before set
+ [ call ] [ drop ] recover
+ datastack after set
+ clear
+ before get [ ] each
+ quot get [ compile-call ] [ errored on ] recover ;
+
+: do-test ! ( data... quot -- )
+ .s flush test-compiler
+ errored get [
+ datastack after get 2dup = [
+ 2drop
+ ] [
+ [ . ] each
+ "--" print
+ [ . ] each
+ quot get .
+ random-tester-error construct-empty throw
+ ] if
+ ] unless clear ;
+
+: random-test1 ( #data #code -- )
+ setup-test do-test ;
+
+: random-test2 ( -- )
+ 3 2 setup-test do-test ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math sequences namespaces hashtables words
+arrays parser compiler syntax io prettyprint optimizer
+random math.constants math.functions layouts random-tester.utils ;
+IN: random-tester
+
+! Tweak me
+: max-length 15 ; inline
+: max-value 1000000000 ; inline
+
+! varying bit-length random number
+: random-bits ( n -- int )
+ random 2 swap ^ random ;
+
+: random-seq ( -- seq )
+ { [ ] { } V{ } "" } random
+ [ max-length random [ max-value random , ] times ] swap make ;
+
+: random-string
+ [ max-length random [ max-value random , ] times ] "" make ;
+
+: special-integers ( -- seq ) \ special-integers get ;
+[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
+{ } make \ special-integers set-global
+: special-floats ( -- seq ) \ special-floats get ;
+[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
+{ } make \ special-floats set-global
+: special-complexes ( -- seq ) \ special-complexes get ;
+[
+ { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
+ e , e neg , pi , pi neg ,
+ 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
+ pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
+ e neg e neg rect> , e e rect> ,
+] { } make \ special-complexes set-global
+
+: random-fixnum ( -- fixnum )
+ most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
+
+: random-bignum ( -- bignum )
+ 400 random-bits first-bignum + 50% [ neg ] when ;
+
+: random-integer ( -- n )
+ 50% [
+ random-fixnum
+ ] [
+ 50% [ random-bignum ] [ special-integers get random ] if
+ ] if ;
+
+: random-positive-integer ( -- int )
+ random-integer dup 0 < [
+ neg
+ ] [
+ dup 0 = [ 1 + ] when
+ ] if ;
+
+: random-ratio ( -- ratio )
+ 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+
+: random-float ( -- float )
+ 50% [ random-ratio ] [ special-floats get random ] if
+ 50%
+ [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
+ >float ;
+
+: random-number ( -- number )
+ {
+ [ random-integer ]
+ [ random-ratio ]
+ [ random-float ]
+ } do-one ;
+
+: random-complex ( -- C )
+ random-number random-number rect> ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel namespaces sequences sorting vocabs ;
+USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
+IN: random-tester.safe-words
+
+: ?-words
+ {
+ delegate
+
+ /f
+
+ bits>float bits>double
+ float>bits double>bits
+
+ >bignum >boolean >fixnum >float
+
+ array? integer? complex? value-ref? ref? key-ref?
+ interval? number?
+ wrapper? tuple?
+ [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
+ 2^ not
+ ! arrays
+ resize-array <array>
+ ! assocs
+ (assoc-stack)
+ new-assoc
+ assoc-like
+ <hashtable>
+ all-integers? (all-integers?) ! hangs?
+ assoc-push-if
+
+ (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
+ } ;
+
+: bignum-words
+ {
+ next-power-of-2 (next-power-of-2)
+ times
+ hashcode hashcode*
+ } ;
+
+: initialization-words
+ {
+ init-namespaces
+ } ;
+
+: stack-words
+ {
+ dup
+ drop 2drop 3drop
+ roll -roll 2swap
+
+ >r r>
+ } ;
+
+: stateful-words
+ {
+ counter
+ gensym
+ } ;
+
+: foo-words
+ {
+ set-retainstack
+ retainstack callstack
+ datastack
+ callstack>array
+ } ;
+
+: exit-words
+ {
+ call-clear die
+ } ;
+
+: bad-words ( -- array )
+ [
+ ?-words %
+ bignum-words %
+ initialization-words %
+ stack-words %
+ stateful-words %
+ exit-words %
+ foo-words %
+ ] { } make ;
+
+: safe-words ( -- array )
+ bad-words {
+ "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
+ ! "classes" "combinators" "compiler" "continuations"
+ ! "core-foundation" "definitions" "documents"
+ ! "float-arrays" "generic" "graphs" "growable"
+ "hashtables" ! io.*
+ "kernel" "math"
+ "math.bitfields" "math.complex" "math.constants" "math.floats"
+ "math.functions" "math.integers" "math.intervals" "math.libm"
+ "math.parser" "math.ratios" "math.vectors"
+ ! "namespaces" "quotations" "sbufs"
+ ! "queues" "strings" "sequences"
+ "vectors"
+ ! "words"
+ } [ words ] map concat seq-diff natural-sort ;
+
+safe-words \ safe-words set-global
+
+! foo dup (clone) = .
+! foo dup clone = .
+! f [ byte-array>bignum assoc-clone-like ] compile-1
+! 2 3.14 [ construct-empty number= ] compile-1
+! 3.14 [ <vector> assoc? ] compile-1
+! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: arrays assocs combinators.lib continuations kernel
+math math.functions memoize namespaces quotations random sequences
+sequences.private shuffle ;
+IN: random-tester.utils
+
+: %chance ( n -- ? )
+ 100 random > ;
+
+: 10% ( -- ? ) 10 %chance ;
+: 20% ( -- ? ) 20 %chance ;
+: 30% ( -- ? ) 30 %chance ;
+: 40% ( -- ? ) 40 %chance ;
+: 50% ( -- ? ) 50 %chance ;
+: 60% ( -- ? ) 60 %chance ;
+: 70% ( -- ? ) 70 %chance ;
+: 80% ( -- ? ) 80 %chance ;
+: 90% ( -- ? ) 90 %chance ;
+
+: call-if ( quot ? -- ) swap when ; inline
+
+: with-10% ( quot -- ) 10% call-if ; inline
+: with-20% ( quot -- ) 20% call-if ; inline
+: with-30% ( quot -- ) 30% call-if ; inline
+: with-40% ( quot -- ) 40% call-if ; inline
+: with-50% ( quot -- ) 50% call-if ; inline
+: with-60% ( quot -- ) 60% call-if ; inline
+: with-70% ( quot -- ) 70% call-if ; inline
+: with-80% ( quot -- ) 80% call-if ; inline
+: with-90% ( quot -- ) 90% call-if ; inline
+
+: random-key keys random ;
+: random-value [ random-key ] keep at ;
+
+: do-one ( seq -- ) random call ; inline
-#ifndef DEBUG
- CFLAGS += -fomit-frame-pointer
-#endif
+CFLAGS += -fomit-frame-pointer
EXE_SUFFIX =
DLL_PREFIX = lib
build_free_list(heap,heap->segment->size);
}
-/* Compute total sum of sizes of free blocks */
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{
- CELL size = 0;
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
{
- if(scan->status == status)
- size += scan->size;
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ critical_error("Invalid scan->status",(CELL)scan);
+ }
+
scan = next_block(heap,scan);
}
-
- return size;
}
/* The size of the heap, not including the last block if it's free */
/* Push the free space and total size of the code heap */
DEFINE_PRIMITIVE(code_room)
{
- dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
-}
-
-void code_gc(void)
-{
- garbage_collection(TENURED,true,false,0);
-}
-
-DEFINE_PRIMITIVE(code_gc)
-{
- code_gc();
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
- code_gc();
+ gc();
fprintf(stderr,"*** Code heap compaction...\n");
fflush(stderr);
CELL heap_allot(F_HEAP *heap, CELL size);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
-void code_gc(void);
void compact_code_heap(void);
DECLARE_PRIMITIVE(code_room);
-DECLARE_PRIMITIVE(code_gc);
/* If allocation failed, do a code GC */
if(start == 0)
{
- code_gc();
+ gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == 0)
+ {
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
+
+ fprintf(stderr,"Code heap stats:\n");
+ fprintf(stderr,"Used: %ld\n",used);
+ fprintf(stderr,"Total free space: %ld\n",total_free);
+ fprintf(stderr,"Largest free block: %ld\n",max_free);
fatal_error("Out of memory in add-compiled-block",0);
+ }
}
return start;
#include "master.h"
+#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
+#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
+#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
+#define END_GC "end_gc: gc_elapsed=%ld\n"
+#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
+#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
+
+#ifdef GC_DEBUG
+ #define GC_PRINT printf
+#else
+ INLINE void GC_PRINT() { }
+#endif
+
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
- (data_heap->segment->start >> CARD_BITS);
}
-F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
+F_DATA_HEAP *alloc_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size)
{
+ GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
+
young_size = align_page(young_size);
aging_size = align_page(aging_size);
+ tenured_size = align_page(tenured_size);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
+ data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 1)
- total_size = 2 * aging_size;
+ total_size = 2 * tenured_size;
else if(data_heap->gen_count == 2)
- total_size = (gens - 1) * young_size + 2 * aging_size;
+ total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
- total_size = gens * young_size + 2 * aging_size;
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
data_heap->segment = alloc_segment(total_size);
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * gens);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * gens);
+ data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size / CARD_SIZE;
data_heap->cards = safe_malloc(cards_size);
CELL alloter = data_heap->segment->start;
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
-
- alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter);
+ alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
- int i;
-
- if(data_heap->gen_count > 2)
+ if(data_heap->gen_count == 3)
{
- alloter = init_zone(&data_heap->generations[AGING],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],young_size,alloter);
-
- for(i = gens - 3; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
- else
+
+ if(data_heap->gen_count >= 2)
{
- for(i = gens - 2; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(alloter != data_heap->segment->end)
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
- CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
- CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
+ CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
- new_young_size,
- new_aging_size);
+ data_heap->young_size,
+ data_heap->aging_size,
+ new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_)
{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size));
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
extra_roots = extra_roots_region->start - CELLS;
gc_time = 0;
- minor_collections = 0;
+ aging_collections = 0;
+ nursery_collections = 0;
cards_scanned = 0;
secure_gc = secure_gc_;
}
DEFINE_PRIMITIVE(begin_scan)
{
- data_gc();
+ gc();
begin_scan();
}
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
{
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
{
do_slots(scan,copy_handle);
- if(collecting_code)
+ if(collecting_gen == TENURED)
do_code_slots(scan);
return scan + untagged_object_size(scan);
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
-}
-void major_gc_message(void)
-{
- fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
- collecting_code ? "Code and data" : "Data",
- minor_collections,cards_scanned);
- fflush(stderr);
- minor_collections = 0;
- cards_scanned = 0;
+#ifdef GC_DEBUG
+ printf("\n");
+ dump_generations();
+ printf("Newspace: ");
+ dump_zone(newspace);
+ printf("\n");
+#endif
}
void end_gc(void)
dealloc_data_heap(old_data_heap);
old_data_heap = NULL;
growing_data_heap = false;
-
- fprintf(stderr,"*** Data heap resized to %lu bytes\n",
- data_heap->segment->size);
}
if(collecting_accumulation_gen_p())
reset_generations(NURSERY,collecting_gen - 1);
if(collecting_gen == TENURED)
- major_gc_message();
+ {
+ GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
+ aging_collections = 0;
+ cards_scanned = 0;
+ }
else if(HAVE_AGING_P && collecting_gen == AGING)
- minor_collections++;
+ {
+ aging_collections++;
+
+ GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
+ nursery_collections = 0;
+ cards_scanned = 0;
+ }
}
else
{
collected are now empty */
reset_generations(NURSERY,collecting_gen);
- minor_collections++;
+ nursery_collections++;
}
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void garbage_collection(CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes)
{
return;
}
+ GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
+
s64 start = current_millis();
performing_gc = true;
- collecting_code = code_gc;
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
growing_data_heap = true;
/* see the comment in unmark_marked() */
- if(collecting_code)
- unmark_marked(&code_heap);
+ unmark_marked(&code_heap);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
}
}
+ GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
/* collect objects referenced from older generations */
collect_cards();
- if(!collecting_code)
+ if(collecting_gen != TENURED)
{
/* don't scan code heap unless it has pointers to this
generation or younger */
while(scan < newspace->here)
scan = collect_next(scan);
+ CELL gc_elapsed = (current_millis() - start);
+
+ GC_PRINT(END_GC,gc_elapsed);
end_gc();
- gc_time += (current_millis() - start);
+ gc_time += gc_elapsed;
performing_gc = false;
}
-void data_gc(void)
+void gc(void)
{
- garbage_collection(TENURED,false,false,0);
+ garbage_collection(TENURED,false,0);
}
-DEFINE_PRIMITIVE(data_gc)
+DEFINE_PRIMITIVE(gc)
{
- data_gc();
+ gc();
}
/* Push total time spent on GC */
void simple_gc(void)
{
- maybe_gc(0);
+ if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end)
+ garbage_collection(NURSERY,false,0);
}
DEFINE_PRIMITIVE(become)
forward_object(old_obj,new_obj);
}
- data_gc();
+ gc();
+}
+
+CELL find_all_words(void)
+{
+ GROWABLE_ARRAY(words);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ GROWABLE_ADD(words,obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ GROWABLE_TRIM(words);
+
+ return words;
}
DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
+void gc(void);
+
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
CELL young_size;
CELL aging_size;
+ CELL tenured_size;
CELL gen_count;
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_);
/* statistics */
s64 gc_time;
-CELL minor_collections;
+CELL nursery_collections;
+CELL aging_collections;
CELL cards_scanned;
/* only meaningful during a GC */
bool performing_gc;
CELL collecting_gen;
-bool collecting_code;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
}
}
-/* test if the pointer is in generation being collected, or a younger one.
-init_data_heap() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
+/* test if the pointer is in generation being collected, or a younger one. */
INLINE bool should_copy(CELL untagged)
{
if(in_zone(newspace,untagged))
bool gc_off;
void garbage_collection(volatile CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes);
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
-INLINE void maybe_gc(CELL a)
-{
- /* If we are requesting a huge object, grow immediately */
- if(nursery->size - ALLOT_BUFFER_ZONE <= a)
- garbage_collection(TENURED,false,true,a);
- /* If we have enough space in the nursery, just return.
- Otherwise, perform a GC - this may grow the heap if
- tenured space cannot hold all live objects from the nursery
- even after a full GC */
- else if(a + ALLOT_BUFFER_ZONE + nursery->here > nursery->end)
- garbage_collection(NURSERY,false,false,0);
- /* There is now sufficient room in the nursery for 'a' */
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-INLINE void* allot_object(CELL type, CELL length)
+INLINE void* allot_object(CELL type, CELL a)
{
- maybe_gc(length);
- CELL* object = allot_zone(nursery,length);
+ CELL *object;
+
+ if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
+ garbage_collection(NURSERY,false,0);
+
+ object = allot_zone(nursery,a);
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
*object = tag_header(type);
return object;
}
DLLEXPORT void simple_gc(void);
-void data_gc(void);
-
-DECLARE_PRIMITIVE(data_gc);
+DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
+
+CELL find_all_words(void);
}
}
+void print_datastack(void)
+{
+ printf("==== DATA STACK:\n");
+ print_objects(ds_bot,ds);
+}
+
+void print_retainstack(void)
+{
+ printf("==== RETAIN STACK:\n");
+ print_objects(rs_bot,rs);
+}
+
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
void print_callstack(void)
{
+ printf("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
dump_cell(from);
}
-void dump_zone(F_ZONE z)
+void dump_zone(F_ZONE *z)
{
- printf("start=%lx, size=%lx, end=%lx, here=%lx\n",
- z.start,z.size,z.end,z.here - z.start);
+ printf("start=%ld, size=%ld, here=%ld\n",
+ z->start,z->size,z->here - z->start);
}
void dump_generations(void)
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
- dump_zone(data_heap->generations[i]);
+ dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Semispace %d: ",i);
- dump_zone(data_heap->semispaces[i]);
+ dump_zone(&data_heap->semispaces[i]);
}
printf("Cards: base=%lx, size=%lx\n",
void dump_objects(F_FIXNUM type)
{
- data_gc();
+ gc();
begin_scan();
CELL obj;
printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
+ bool seen_command = false;
+
for(;;)
{
char cmd[1024];
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
exit(1);
+ }
+
+ seen_command = true;
if(strcmp(cmd,"d") == 0)
{
else if(strcmp(cmd,"r") == 0)
dump_memory(rs_bot,rs);
else if(strcmp(cmd,".s") == 0)
- print_objects(ds_bot,ds);
+ print_datastack();
else if(strcmp(cmd,".r") == 0)
- print_objects(rs_bot,rs);
+ print_retainstack();
else if(strcmp(cmd,".c") == 0)
print_callstack();
else if(strcmp(cmd,"e") == 0)
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
+void dump_zone(F_ZONE *z);
DECLARE_PRIMITIVE(die);
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
+
+/* For testing purposes */
+DEFINE_PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
+}
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
+
+DECLARE_PRIMITIVE(unimplemented);
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
- p->aging_size = 6;
+ p->aging_size = 1;
+ p->tenured_size = 6;
#else
p->ds_size = 32 * CELLS;
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 2 * CELLS;
- p->aging_size = 4 * CELLS;
+ p->young_size = CELLS / 4;
+ p->aging_size = CELLS / 2;
+ p->tenured_size = 4 * CELLS;
#endif
p->secure_gc = false;
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
- GROWABLE_ARRAY(words);
+ CELL words = find_all_words();
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_TRIM(words);
REGISTER_ROOT(words);
CELL i;
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
+ p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
else if(factor_arg(argv[i],STR_FORMAT("-young=%d"),&p.young_size));
else if(factor_arg(argv[i],STR_FORMAT("-aging=%d"),&p.aging_size));
+ else if(factor_arg(argv[i],STR_FORMAT("-tenured=%d"),&p.tenured_size));
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
{
return x.x;
}
+
+int ffi_test_37(int (*f)(int, int, int))
+{
+ static int global_var = 0;
+ printf("ffi_test_37\n");
+ global_var = f(global_var,global_var * 2,global_var * 3);
+ printf("global_var is %d\n",global_var);
+ fflush(stdout);
+ return global_var;
+}
--- /dev/null
+ .cstring
+LC0:
+ .ascii "ffi_test_0()\0"
+ .text
+.globl _ffi_test_0
+_ffi_test_0:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $20, %esp
+ call L3
+"L00000000001$pb":
+L3:
+ popl %ebx
+ leal LC0-"L00000000001$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_puts$stub
+ addl $20, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC1:
+ .ascii "ffi_test_1()\0"
+ .text
+.globl _ffi_test_1
+_ffi_test_1:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $20, %esp
+ call L6
+"L00000000002$pb":
+L6:
+ popl %ebx
+ leal LC1-"L00000000002$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_puts$stub
+ movl $3, %eax
+ addl $20, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC2:
+ .ascii "ffi_test_2(%d,%d)\12\0"
+ .text
+.globl _ffi_test_2
+_ffi_test_2:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $20, %esp
+ call L9
+"L00000000003$pb":
+L9:
+ popl %ebx
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC2-"L00000000003$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ addl 8(%ebp), %eax
+ addl $20, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC3:
+ .ascii "ffi_test_3(%d,%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_3
+_ffi_test_3:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L12
+"L00000000004$pb":
+L12:
+ popl %ebx
+ movl 20(%ebp), %eax
+ movl %eax, 16(%esp)
+ movl 16(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC3-"L00000000004$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ movl 8(%ebp), %edx
+ addl %eax, %edx
+ movl 16(%ebp), %eax
+ imull 20(%ebp), %eax
+ leal (%edx,%eax), %eax
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC4:
+ .ascii "ffi_test_4()\0"
+ .literal4
+ .align 2
+LC5:
+ .long 1069547520
+ .text
+.globl _ffi_test_4
+_ffi_test_4:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L15
+"L00000000005$pb":
+L15:
+ popl %ebx
+ leal LC4-"L00000000005$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_puts$stub
+ leal LC5-"L00000000005$pb"(%ebx), %eax
+ movl (%eax), %eax
+ movl %eax, -12(%ebp)
+ movss -12(%ebp), %xmm0
+ movss %xmm0, -12(%ebp)
+ flds -12(%ebp)
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC6:
+ .ascii "ffi_test_5()\0"
+ .literal8
+ .align 3
+LC7:
+ .long 0
+ .long 1073217536
+ .text
+.globl _ffi_test_5
+_ffi_test_5:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L18
+"L00000000006$pb":
+L18:
+ popl %ebx
+ leal LC6-"L00000000006$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_puts$stub
+ leal LC7-"L00000000006$pb"(%ebx), %eax
+ movsd (%eax), %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC8:
+ .ascii "ffi_test_6(%f,%f)\12\0"
+ .text
+.globl _ffi_test_6
+_ffi_test_6:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $52, %esp
+ call L21
+"L00000000007$pb":
+L21:
+ popl %ebx
+ cvtss2sd 12(%ebp), %xmm0
+ cvtss2sd 8(%ebp), %xmm1
+ movsd %xmm0, 12(%esp)
+ movsd %xmm1, 4(%esp)
+ leal LC8-"L00000000007$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movss 8(%ebp), %xmm0
+ mulss 12(%ebp), %xmm0
+ cvtss2sd %xmm0, %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ addl $52, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC9:
+ .ascii "ffi_test_7(%f,%f)\12\0"
+ .text
+.globl _ffi_test_7
+_ffi_test_7:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $68, %esp
+ call L24
+"L00000000008$pb":
+L24:
+ popl %ebx
+ movl 8(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 12(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl 16(%ebp), %eax
+ movl %eax, -24(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -20(%ebp)
+ movsd -24(%ebp), %xmm0
+ movsd %xmm0, 12(%esp)
+ movsd -16(%ebp), %xmm0
+ movsd %xmm0, 4(%esp)
+ leal LC9-"L00000000008$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movsd -16(%ebp), %xmm0
+ mulsd -24(%ebp), %xmm0
+ movsd %xmm0, -32(%ebp)
+ fldl -32(%ebp)
+ addl $68, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC10:
+ .ascii "ffi_test_8(%f,%f,%f,%f,%d)\12\0"
+ .text
+.globl _ffi_test_8
+_ffi_test_8:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $84, %esp
+ call L27
+"L00000000009$pb":
+L27:
+ popl %ebx
+ movl 8(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 12(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -24(%ebp)
+ movl 24(%ebp), %eax
+ movl %eax, -20(%ebp)
+ cvtss2sd 28(%ebp), %xmm0
+ cvtss2sd 16(%ebp), %xmm1
+ movl 32(%ebp), %eax
+ movl %eax, 36(%esp)
+ movsd %xmm0, 28(%esp)
+ movsd -24(%ebp), %xmm0
+ movsd %xmm0, 20(%esp)
+ movsd %xmm1, 12(%esp)
+ movsd -16(%ebp), %xmm0
+ movsd %xmm0, 4(%esp)
+ leal LC10-"L00000000009$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ cvtss2sd 16(%ebp), %xmm0
+ movapd %xmm0, %xmm1
+ mulsd -16(%ebp), %xmm1
+ cvtss2sd 28(%ebp), %xmm0
+ mulsd -24(%ebp), %xmm0
+ addsd %xmm0, %xmm1
+ cvtsi2sd 32(%ebp), %xmm0
+ addsd %xmm1, %xmm0
+ movsd %xmm0, -32(%ebp)
+ fldl -32(%ebp)
+ addl $84, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+ .align 2
+LC11:
+ .ascii "ffi_test_9(%d,%d,%d,%d,%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_9
+_ffi_test_9:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L30
+"L00000000010$pb":
+L30:
+ popl %ebx
+ movl 32(%ebp), %eax
+ movl %eax, 28(%esp)
+ movl 28(%ebp), %eax
+ movl %eax, 24(%esp)
+ movl 24(%ebp), %eax
+ movl %eax, 20(%esp)
+ movl 20(%ebp), %eax
+ movl %eax, 16(%esp)
+ movl 16(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC11-"L00000000010$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ addl 8(%ebp), %eax
+ addl 16(%ebp), %eax
+ addl 20(%ebp), %eax
+ addl 24(%ebp), %eax
+ addl 28(%ebp), %eax
+ addl 32(%ebp), %eax
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+ .align 2
+LC12:
+ .ascii "ffi_test_10(%d,%d,%f,%d,%f,%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_10
+_ffi_test_10:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $68, %esp
+ call L33
+"L00000000011$pb":
+L33:
+ popl %ebx
+ movl 16(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -12(%ebp)
+ cvtss2sd 28(%ebp), %xmm0
+ movl 40(%ebp), %eax
+ movl %eax, 40(%esp)
+ movl 36(%ebp), %eax
+ movl %eax, 36(%esp)
+ movl 32(%ebp), %eax
+ movl %eax, 32(%esp)
+ movsd %xmm0, 24(%esp)
+ movl 24(%ebp), %eax
+ movl %eax, 20(%esp)
+ movsd -16(%ebp), %xmm0
+ movsd %xmm0, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC12-"L00000000011$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %edx
+ movl 8(%ebp), %eax
+ subl %edx, %eax
+ cvtsi2sd %eax, %xmm0
+ movapd %xmm0, %xmm1
+ subsd -16(%ebp), %xmm1
+ cvtsi2sd 24(%ebp), %xmm0
+ subsd %xmm0, %xmm1
+ cvtss2sd 28(%ebp), %xmm0
+ subsd %xmm0, %xmm1
+ cvtsi2sd 32(%ebp), %xmm0
+ subsd %xmm0, %xmm1
+ cvtsi2sd 36(%ebp), %xmm0
+ subsd %xmm0, %xmm1
+ cvtsi2sd 40(%ebp), %xmm0
+ movapd %xmm1, %xmm2
+ subsd %xmm0, %xmm2
+ movapd %xmm2, %xmm0
+ cvttsd2si %xmm0, %eax
+ addl $68, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC13:
+ .ascii "ffi_test_11(%d,{%d,%d},%d)\12\0"
+ .text
+.globl _ffi_test_11
+_ffi_test_11:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L36
+"L00000000012$pb":
+L36:
+ popl %ebx
+ movl 16(%ebp), %edx
+ movl 12(%ebp), %ecx
+ movl 20(%ebp), %eax
+ movl %eax, 16(%esp)
+ movl %edx, 12(%esp)
+ movl %ecx, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC13-"L00000000012$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ movl %eax, %edx
+ imull 8(%ebp), %edx
+ movl 16(%ebp), %eax
+ imull 20(%ebp), %eax
+ leal (%edx,%eax), %eax
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+ .align 2
+LC14:
+ .ascii "ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_12
+_ffi_test_12:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $68, %esp
+ call L39
+"L00000000013$pb":
+L39:
+ popl %ebx
+ movss 28(%ebp), %xmm0
+ cvtss2sd %xmm0, %xmm1
+ movss 24(%ebp), %xmm0
+ cvtss2sd %xmm0, %xmm2
+ movss 20(%ebp), %xmm0
+ cvtss2sd %xmm0, %xmm3
+ movss 16(%ebp), %xmm0
+ cvtss2sd %xmm0, %xmm0
+ movl 40(%ebp), %eax
+ movl %eax, 52(%esp)
+ movl 36(%ebp), %eax
+ movl %eax, 48(%esp)
+ movl 32(%ebp), %eax
+ movl %eax, 44(%esp)
+ movsd %xmm1, 36(%esp)
+ movsd %xmm2, 28(%esp)
+ movsd %xmm3, 20(%esp)
+ movsd %xmm0, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC14-"L00000000013$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ addl 8(%ebp), %eax
+ cvtsi2ss %eax, %xmm1
+ movss 16(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ movss 20(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ movss 24(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ movss 28(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ cvtsi2ss 32(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ cvtsi2ss 36(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ cvtsi2ss 40(%ebp), %xmm0
+ addss %xmm1, %xmm0
+ cvttss2si %xmm0, %eax
+ addl $68, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+ .align 2
+LC15:
+ .ascii "ffi_test_13(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_13
+_ffi_test_13:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $52, %esp
+ call L42
+"L00000000014$pb":
+L42:
+ popl %ebx
+ movl 48(%ebp), %eax
+ movl %eax, 44(%esp)
+ movl 44(%ebp), %eax
+ movl %eax, 40(%esp)
+ movl 40(%ebp), %eax
+ movl %eax, 36(%esp)
+ movl 36(%ebp), %eax
+ movl %eax, 32(%esp)
+ movl 32(%ebp), %eax
+ movl %eax, 28(%esp)
+ movl 28(%ebp), %eax
+ movl %eax, 24(%esp)
+ movl 24(%ebp), %eax
+ movl %eax, 20(%esp)
+ movl 20(%ebp), %eax
+ movl %eax, 16(%esp)
+ movl 16(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC15-"L00000000014$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ addl 8(%ebp), %eax
+ addl 16(%ebp), %eax
+ addl 20(%ebp), %eax
+ addl 24(%ebp), %eax
+ addl 28(%ebp), %eax
+ addl 32(%ebp), %eax
+ addl 36(%ebp), %eax
+ addl 40(%ebp), %eax
+ addl 44(%ebp), %eax
+ addl 48(%ebp), %eax
+ addl $52, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC16:
+ .ascii "ffi_test_14(%d,%d)\12\0"
+ .text
+.globl _ffi_test_14
+_ffi_test_14:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L45
+"L00000000015$pb":
+L45:
+ popl %ebx
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC16-"L00000000015$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 8(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 12(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl -16(%ebp), %eax
+ movl -12(%ebp), %edx
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+ .cstring
+LC17:
+ .ascii "foo\0"
+LC18:
+ .ascii "bar\0"
+ .text
+.globl _ffi_test_15
+_ffi_test_15:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L51
+"L00000000016$pb":
+L51:
+ popl %ebx
+ movl 12(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call L_strcmp$stub
+ testl %eax, %eax
+ je L47
+ leal LC17-"L00000000016$pb"(%ebx), %eax
+ movl %eax, -12(%ebp)
+ jmp L49
+L47:
+ leal LC18-"L00000000016$pb"(%ebx), %eax
+ movl %eax, -12(%ebp)
+L49:
+ movl -12(%ebp), %eax
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret
+.globl _ffi_test_16
+_ffi_test_16:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ movl %eax, -20(%ebp)
+ movl 16(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl -20(%ebp), %eax
+ movl %eax, (%edx)
+ movl -16(%ebp), %eax
+ movl %eax, 4(%edx)
+ movl -12(%ebp), %eax
+ movl %eax, 8(%edx)
+ movl %edx, %eax
+ leave
+ ret $4
+.globl _ffi_test_17
+_ffi_test_17:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl -12(%ebp), %eax
+ leave
+ ret
+ .cstring
+LC19:
+ .ascii "ffi_test_18(%d,%d,%d,%d)\12\0"
+ .text
+.globl _ffi_test_18
+_ffi_test_18:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $36, %esp
+ call L58
+"L00000000017$pb":
+L58:
+ popl %ebx
+ movl 20(%ebp), %eax
+ movl %eax, 16(%esp)
+ movl 16(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC19-"L00000000017$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl 12(%ebp), %eax
+ movl 8(%ebp), %edx
+ addl %eax, %edx
+ movl 16(%ebp), %eax
+ imull 20(%ebp), %eax
+ leal (%edx,%eax), %eax
+ addl $36, %esp
+ popl %ebx
+ leave
+ ret $16
+.globl _ffi_test_19
+_ffi_test_19:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ movl %eax, -20(%ebp)
+ movl 16(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl -20(%ebp), %eax
+ movl %eax, (%edx)
+ movl -16(%ebp), %eax
+ movl %eax, 4(%edx)
+ movl -12(%ebp), %eax
+ movl %eax, 8(%edx)
+ movl %edx, %eax
+ leave
+ ret $16
+ .cstring
+ .align 2
+LC20:
+ .ascii "ffi_test_20(%f,%f,%f,%f,%f,%f,%f,%f,%f)\12\0"
+ .text
+.globl _ffi_test_20
+_ffi_test_20:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $164, %esp
+ call L63
+"L00000000018$pb":
+L63:
+ popl %ebx
+ movl 8(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 12(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl 16(%ebp), %eax
+ movl %eax, -24(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -20(%ebp)
+ movl 24(%ebp), %eax
+ movl %eax, -32(%ebp)
+ movl 28(%ebp), %eax
+ movl %eax, -28(%ebp)
+ movl 32(%ebp), %eax
+ movl %eax, -40(%ebp)
+ movl 36(%ebp), %eax
+ movl %eax, -36(%ebp)
+ movl 40(%ebp), %eax
+ movl %eax, -48(%ebp)
+ movl 44(%ebp), %eax
+ movl %eax, -44(%ebp)
+ movl 48(%ebp), %eax
+ movl %eax, -56(%ebp)
+ movl 52(%ebp), %eax
+ movl %eax, -52(%ebp)
+ movl 56(%ebp), %eax
+ movl %eax, -64(%ebp)
+ movl 60(%ebp), %eax
+ movl %eax, -60(%ebp)
+ movl 64(%ebp), %eax
+ movl %eax, -72(%ebp)
+ movl 68(%ebp), %eax
+ movl %eax, -68(%ebp)
+ movl 72(%ebp), %eax
+ movl %eax, -80(%ebp)
+ movl 76(%ebp), %eax
+ movl %eax, -76(%ebp)
+ movsd -80(%ebp), %xmm0
+ movsd %xmm0, 68(%esp)
+ movsd -72(%ebp), %xmm0
+ movsd %xmm0, 60(%esp)
+ movsd -64(%ebp), %xmm0
+ movsd %xmm0, 52(%esp)
+ movsd -56(%ebp), %xmm0
+ movsd %xmm0, 44(%esp)
+ movsd -48(%ebp), %xmm0
+ movsd %xmm0, 36(%esp)
+ movsd -40(%ebp), %xmm0
+ movsd %xmm0, 28(%esp)
+ movsd -32(%ebp), %xmm0
+ movsd %xmm0, 20(%esp)
+ movsd -24(%ebp), %xmm0
+ movsd %xmm0, 12(%esp)
+ movsd -16(%ebp), %xmm0
+ movsd %xmm0, 4(%esp)
+ leal LC20-"L00000000018$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ addl $164, %esp
+ popl %ebx
+ leave
+ ret
+.globl _ffi_test_21
+_ffi_test_21:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $56, %esp
+ movl 8(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl %eax, %edx
+ sarl $31, %edx
+ movl %edx, -12(%ebp)
+ movl 12(%ebp), %eax
+ movl %eax, -48(%ebp)
+ movl %eax, %edx
+ sarl $31, %edx
+ movl %edx, -44(%ebp)
+ movl -16(%ebp), %eax
+ mull -48(%ebp)
+ movl %eax, -24(%ebp)
+ movl %edx, -20(%ebp)
+ movl -16(%ebp), %edx
+ imull -44(%ebp), %edx
+ movl %edx, -28(%ebp)
+ movl -20(%ebp), %ecx
+ addl -28(%ebp), %ecx
+ movl -48(%ebp), %eax
+ imull -12(%ebp), %eax
+ addl %eax, %ecx
+ movl %ecx, -20(%ebp)
+ movl -24(%ebp), %eax
+ movl -20(%ebp), %edx
+ leave
+ ret
+ .cstring
+LC21:
+ .ascii "ffi_test_22(%ld,%lld,%lld)\12\0"
+ .text
+.globl _ffi_test_22
+_ffi_test_22:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $52, %esp
+ call L68
+"L00000000019$pb":
+L68:
+ popl %ebx
+ movl 12(%ebp), %eax
+ movl %eax, -16(%ebp)
+ movl 16(%ebp), %eax
+ movl %eax, -12(%ebp)
+ movl 20(%ebp), %eax
+ movl %eax, -24(%ebp)
+ movl 24(%ebp), %eax
+ movl %eax, -20(%ebp)
+ movl -24(%ebp), %eax
+ movl -20(%ebp), %edx
+ movl %eax, 16(%esp)
+ movl %edx, 20(%esp)
+ movl -16(%ebp), %eax
+ movl -12(%ebp), %edx
+ movl %eax, 8(%esp)
+ movl %edx, 12(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal LC21-"L00000000019$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ movl -24(%ebp), %eax
+ movl -20(%ebp), %edx
+ movl %eax, 8(%esp)
+ movl %edx, 12(%esp)
+ movl -16(%ebp), %eax
+ movl -12(%ebp), %edx
+ movl %eax, (%esp)
+ movl %edx, 4(%esp)
+ call L___divdi3$stub
+ addl 8(%ebp), %eax
+ addl $52, %esp
+ popl %ebx
+ leave
+ ret
+.globl _ffi_test_23
+_ffi_test_23:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movss (%eax), %xmm1
+ movl 12(%ebp), %eax
+ movss (%eax), %xmm0
+ movaps %xmm1, %xmm2
+ mulss %xmm0, %xmm2
+ movl 8(%ebp), %eax
+ addl $4, %eax
+ movss (%eax), %xmm1
+ movl 12(%ebp), %eax
+ addl $4, %eax
+ movss (%eax), %xmm0
+ mulss %xmm1, %xmm0
+ addss %xmm0, %xmm2
+ movl 8(%ebp), %eax
+ addl $8, %eax
+ movss (%eax), %xmm1
+ movl 12(%ebp), %eax
+ addl $8, %eax
+ movss (%eax), %xmm0
+ mulss %xmm1, %xmm0
+ addss %xmm2, %xmm0
+ movss %xmm0, -12(%ebp)
+ flds -12(%ebp)
+ leave
+ ret
+.globl _ffi_test_24
+_ffi_test_24:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movb $1, -9(%ebp)
+ movzbl -9(%ebp), %eax
+ leave
+ ret
+.globl _ffi_test_25
+_ffi_test_25:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movb $1, -10(%ebp)
+ movb $2, -9(%ebp)
+ movzwl -10(%ebp), %eax
+ leave
+ ret
+.globl _ffi_test_26
+_ffi_test_26:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movb $1, -11(%ebp)
+ movb $2, -10(%ebp)
+ movb $3, -9(%ebp)
+ movzwl -11(%ebp), %edx
+ movw %dx, (%eax)
+ movzbl -9(%ebp), %edx
+ movb %dl, 2(%eax)
+ leave
+ ret $4
+.globl _ffi_test_27
+_ffi_test_27:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movb $1, -12(%ebp)
+ movb $2, -11(%ebp)
+ movb $3, -10(%ebp)
+ movb $4, -9(%ebp)
+ movl -12(%ebp), %eax
+ leave
+ ret
+.globl _ffi_test_28
+_ffi_test_28:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movb $1, -13(%ebp)
+ movb $2, -12(%ebp)
+ movb $3, -11(%ebp)
+ movb $4, -10(%ebp)
+ movb $5, -9(%ebp)
+ movl -13(%ebp), %edx
+ movl %edx, (%eax)
+ movzbl -9(%ebp), %edx
+ movb %dl, 4(%eax)
+ leave
+ ret $4
+.globl _ffi_test_29
+_ffi_test_29:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movb $1, -14(%ebp)
+ movb $2, -13(%ebp)
+ movb $3, -12(%ebp)
+ movb $4, -11(%ebp)
+ movb $5, -10(%ebp)
+ movb $6, -9(%ebp)
+ movl -14(%ebp), %edx
+ movl %edx, (%eax)
+ movzwl -10(%ebp), %edx
+ movw %dx, 4(%eax)
+ leave
+ ret $4
+.globl _ffi_test_30
+_ffi_test_30:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %edx
+ movb $1, -15(%ebp)
+ movb $2, -14(%ebp)
+ movb $3, -13(%ebp)
+ movb $4, -12(%ebp)
+ movb $5, -11(%ebp)
+ movb $6, -10(%ebp)
+ movb $7, -9(%ebp)
+ movl -15(%ebp), %eax
+ movl %eax, (%edx)
+ movzwl -11(%ebp), %eax
+ movw %ax, 4(%edx)
+ movzbl -9(%ebp), %eax
+ movb %al, 6(%edx)
+ movl %edx, %eax
+ leave
+ ret $4
+.globl _ffi_test_31
+_ffi_test_31:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ leave
+ ret
+.globl _ffi_test_32
+_ffi_test_32:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movsd 8(%ebp), %xmm1
+ movsd 16(%ebp), %xmm0
+ addsd %xmm0, %xmm1
+ cvtsi2sd 24(%ebp), %xmm0
+ mulsd %xmm1, %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ leave
+ ret
+.globl _ffi_test_33
+_ffi_test_33:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movss 8(%ebp), %xmm1
+ movss 12(%ebp), %xmm0
+ addss %xmm0, %xmm1
+ cvtsi2ss 16(%ebp), %xmm0
+ mulss %xmm1, %xmm0
+ cvtss2sd %xmm0, %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ leave
+ ret
+.globl _ffi_test_34
+_ffi_test_34:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movss 8(%ebp), %xmm1
+ movl 12(%ebp), %eax
+ cvtsi2ss %eax, %xmm0
+ addss %xmm0, %xmm1
+ cvtsi2ss 16(%ebp), %xmm0
+ mulss %xmm1, %xmm0
+ cvtss2sd %xmm0, %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ leave
+ ret
+.globl _ffi_test_35
+_ffi_test_35:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ leal (%edx,%eax), %eax
+ imull 16(%ebp), %eax
+ cvtsi2sd %eax, %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ leave
+ ret
+.globl _ffi_test_36
+_ffi_test_36:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movsd 12(%ebp), %xmm0
+ movsd %xmm0, -16(%ebp)
+ fldl -16(%ebp)
+ leave
+ ret
+.lcomm _global_var.12587,4,2
+ .cstring
+LC22:
+ .ascii "ffi_test_37\0"
+LC23:
+ .ascii "global_var is %d\12\0"
+ .text
+.globl _ffi_test_37
+_ffi_test_37:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $20, %esp
+ call L99
+"L00000000020$pb":
+L99:
+ popl %ebx
+ leal LC22-"L00000000020$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_puts$stub
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl (%eax), %edx
+ movl %edx, %eax
+ addl %eax, %eax
+ leal (%eax,%edx), %ecx
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl (%eax), %eax
+ leal (%eax,%eax), %edx
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl (%eax), %eax
+ movl %ecx, 8(%esp)
+ movl %edx, 4(%esp)
+ movl %eax, (%esp)
+ movl 8(%ebp), %eax
+ call *%eax
+ movl %eax, %edx
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl %edx, (%eax)
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ leal LC23-"L00000000020$pb"(%ebx), %eax
+ movl %eax, (%esp)
+ call L_printf$stub
+ leal _global_var.12587-"L00000000020$pb"(%ebx), %eax
+ movl (%eax), %eax
+ addl $20, %esp
+ popl %ebx
+ leave
+ ret
+.comm _our_exception_port,4,2
+.comm _userenv,256,5
+.comm _T,4,2
+.comm _stack_chain,4,2
+.comm _ds_size,4,2
+.comm _rs_size,4,2
+.comm _stage2,1,0
+.comm _profiling_p,1,0
+.comm _signal_number,4,2
+.comm _signal_fault_addr,4,2
+.comm _signal_callstack_top,4,2
+.comm _secure_gc,1,0
+.comm _data_heap,4,2
+.comm _cards_offset,4,2
+.comm _newspace,4,2
+.comm _nursery,4,2
+.comm _gc_time,8,3
+.comm _nursery_collections,4,2
+.comm _aging_collections,4,2
+.comm _cards_scanned,4,2
+.comm _performing_gc,1,0
+.comm _collecting_gen,4,2
+.comm _collecting_aging_again,1,0
+.comm _last_code_heap_scan,4,2
+.comm _growing_data_heap,1,0
+.comm _old_data_heap,4,2
+.comm _gc_jmp,72,5
+.comm _heap_scan_ptr,4,2
+.comm _gc_off,1,0
+.comm _gc_locals_region,4,2
+.comm _gc_locals,4,2
+.comm _extra_roots_region,4,2
+.comm _extra_roots,4,2
+.comm _bignum_zero,4,2
+.comm _bignum_pos_one,4,2
+.comm _bignum_neg_one,4,2
+.comm _code_heap,8,2
+.comm _data_relocation_base,4,2
+.comm _code_relocation_base,4,2
+.comm _posix_argc,4,2
+.comm _posix_argv,4,2
+ .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5
+L___divdi3$stub:
+ .indirect_symbol ___divdi3
+ hlt ; hlt ; hlt ; hlt ; hlt
+L_printf$stub:
+ .indirect_symbol _printf
+ hlt ; hlt ; hlt ; hlt ; hlt
+L_puts$stub:
+ .indirect_symbol _puts
+ hlt ; hlt ; hlt ; hlt ; hlt
+L_strcmp$stub:
+ .indirect_symbol _strcmp
+ hlt ; hlt ; hlt ; hlt ; hlt
+ .subsections_via_symbols
{
CELL good_size = h->data_size + (1 << 20);
- if(good_size > p->aging_size)
- p->aging_size = good_size;
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
- init_data_heap(p->gen_count,p->young_size,p->aging_size,p->secure_gc);
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
F_ZONE *tenured = &data_heap->generations[TENURED];
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
- code_gc();
+ gc();
save_image(unbox_native_string());
}
typedef struct {
const F_CHAR* image;
CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size;
+ CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;
bool secure_gc;
bool fep;
#include "layouts.h"
#include "platform.h"
#include "primitives.h"
-#include "debug.h"
#include "run.h"
#include "profiler.h"
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
#include "data_gc.h"
+#include "debug.h"
#include "types.h"
#include "math.h"
#include "float_bits.h"
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
#ifndef environ
extern char ***_NSGetEnviron(void);
#define environ (*_NSGetEnviron())
-#endif
\ No newline at end of file
+#endif
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
dpush(result);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ char *name = unbox_char_string();
+ char *value = getenv(name);
+ if(value == NULL)
+ dpush(F);
+ else
+ box_char_string(value);
+}
+
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_env)
+{
+ char *key = unbox_char_string();
+ REGISTER_C_STRING(key);
+ char *value = unbox_char_string();
+ UNREGISTER_C_STRING(key);
+ setenv(key, value, 1);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ char *key = unbox_char_string();
+ unsetenv(key);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
F_ARRAY *array = untag_array(dpop());
Sleep(msec);
}
-DECLARE_PRIMITIVE(set_os_envs)
+DEFINE_PRIMITIVE(os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ F_CHAR *value = safe_malloc(MAX_UNICODE_PATH * 2);
+ int ret;
+ ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH * 2);
+ if(ret == 0)
+ dpush(F);
+ else
+ dpush(tag_object(from_u16_string(value)));
+ free(value);
+}
+
+DEFINE_PRIMITIVE(set_os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ REGISTER_C_STRING(key);
+ F_CHAR *value = unbox_u16_string();
+ UNREGISTER_C_STRING(key);
+ if(!SetEnvironmentVariable(key, value))
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
+ && GetLastError() != ERROR_ENVVAR_NOT_FOUND)
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
+DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
}
#include "os-unix.h"
#ifdef __APPLE__
- #include "os-unix-ucontext.h"
#include "os-macosx.h"
#include "mach_signal.h"
#if defined(FACTOR_X86)
#include "os-linux-x86.32.h"
#elif defined(FACTOR_PPC)
- #include "os-unix-ucontext.h"
#include "os-linux-ppc.h"
#elif defined(FACTOR_ARM)
#include "os-linux-arm.h"
primitive_setenv,
primitive_existsp,
primitive_read_dir,
- primitive_data_gc,
- primitive_code_gc,
+ primitive_gc,
primitive_gc_time,
primitive_save_image,
primitive_save_image_and_exit,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_env,
+ primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
primitive_resize_float_array,
primitive_dll_validp,
+ primitive_unimplemented,
};
profiling_p = profiling;
- /* Push everything to tenured space so that we can heap scan,
- also code GC so that we can allocate profiling blocks if
- necessary */
- code_gc();
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
- /* Update word XTs and saved callstack objects */
- begin_scan();
+ CELL words = find_all_words();
- CELL obj;
- while((obj = next_object()) != F)
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
{
- if(type_of(obj) == WORD_TYPE)
- update_word_xt(untag_object(obj));
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ update_word_xt(word);
}
- gc_off = false; /* end heap scan */
+ UNREGISTER_ROOT(words);
/* Update XTs in code heap */
iterate_code_heap(relocate_code_block);
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(os_env)
-{
- char *name = unbox_char_string();
- char *value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(value);
-}
-
DEFINE_PRIMITIVE(eq)
{
CELL lhs = dpop();
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_env);
+DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
- word->hashcode = tag_fixnum(rand());
+ word->hashcode = tag_fixnum((rand() << 16) ^ rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->counter = tag_fixnum(0);
word->compiledp = F;
word->profiling = NULL;
+ word->code = NULL;
REGISTER_UNTAGGED(word);
default_word_code(word,true);
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
- set_array_nth(array,i,fill);
+ put(AREF(array,i),fill);
}
return array;
}
memcpy(new_array + 1,array + 1,to_copy * CELLS);
for(i = to_copy; i < capacity; i++)
- set_array_nth(new_array,i,fill);
+ put(AREF(new_array,i),fill);
return new_array;
}
UNREGISTER_UNTAGGED(elts);
+ write_barrier((CELL)result);
+
memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
untag_fixnum_fast(string->length)
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
+
+ write_barrier((CELL)string);
string->aux = tag_object(aux);
}
}
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- new_string->aux = tag_object(new_aux);
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ new_string->aux = tag_object(new_aux);
+
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
projects / factor.git / commitdiff