namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators ;
+accessors combinators effects ;
IN: alien.c-types
DEFER: <int>
>r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- )
- [ to-array-word ] 2keep >c-array-quot define ;
+ [ to-array-word ] 2keep >c-array-quot
+ (( array -- byte-array )) define-declared ;
: c-array>quot ( type vocab -- quot )
[
>r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- )
- [ from-array-word ] 2keep c-array>quot define ;
+ [ from-array-word ] 2keep c-array>quot
+ (( c-ptr n -- array )) define-declared ;
: define-primitive-type ( type name -- )
"alien.c-types"
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-: indirect-test-1
+: indirect-test-1 ( ptr -- result )
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ -1 indirect-test-1 ] must-fail
-: indirect-test-2
+: indirect-test-2 ( x y ptr -- result )
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
-: indirect-test-3
+: indirect-test-3 ( a b c d ptr -- result )
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
! Make sure XT doesn't get clobbered in stack frame
-: ffi_test_31
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
"void"
f "ffi_test_31"
{ "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" }
! Test callbacks
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
] with-scope
] unit-test
-: callback-4
+: callback-4 ( -- callback )
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
-: callback-5
+: callback-5 ( -- callback )
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
-: callback-5a
+: callback-5a ( -- callback )
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! ] unit-test
! ] unless
-: callback-6
+: callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-: callback-7
+: callback-7 ( -- callback )
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
-: callback-8
+: callback-8 ( -- callback )
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
-: callback-9
+: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
-: pop-parameters pop-literal nip [ expand-constants ] map ;
+: pop-parameters ( -- seq )
+ pop-literal nip [ expand-constants ] map ;
: stdcall-mangle ( symbol node -- symbol )
"@"
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
-: eval-callback
+: eval-callback ( -- callback )
"void*" { "char*" } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
-: yield-callback
+: yield-callback ( -- callback )
"void" { } "cdecl" [ yield ] alien-callback ;
-: sleep-callback
+: sleep-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
-quotations math.parser splitting effects prettyprint
+quotations math.parser splitting grouping effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
"All associative mappings must implement methods on the following generic words:"
{ $subsection at* }
{ $subsection assoc-size }
-"At least one of the following two generic words must have a method; the " { $link assoc } " mixin has default definitions which are mutually recursive:"
{ $subsection >alist }
-{ $subsection assoc-find }
"Mutable assocs should implement the following additional words:"
{ $subsection set-at }
{ $subsection delete-at }
$nl
"The standard functional programming idioms:"
{ $subsection assoc-each }
+{ $subsection assoc-find }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-filter }
HELP: assoc-find
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
-{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." }
-{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
+{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
{ $values { "assoc" assoc } }
GENERIC: >alist ( assoc -- newassoc )
-GENERIC# assoc-find 1 ( assoc quot -- key value ? ) inline
-
-M: assoc assoc-find
- >r >alist [ first2 ] r> compose find swap
- [ first2 t ] [ drop f f f ] if ;
+: assoc-find ( assoc quot -- key value ? )
+ >r >alist r> [ first2 ] prepose find swap
+ [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
-M: assoc >alist [ 2array ] { } assoc>map ;
+! M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
enable-compiler
-: compile-uncompiled [ compiled? not ] filter compile ;
+: compile-uncompiled ( words -- )
+ [ compiled? not ] filter compile ;
nl
"Compiling..." write flush
underlying
- find-pair-next namestack*
+ namestack*
bitand bitor bitxor bitnot
} compile-uncompiled
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.builtin classes.tuple
+splitting grouping 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
: 1-offset 8 ; inline
: -1-offset 9 ; inline
-: array-start 2 bootstrap-cells object tag-number - ;
-: scan@ array-start bootstrap-cell - ;
-: wrapper@ bootstrap-cell object tag-number - ;
-: word-xt@ 8 bootstrap-cells object tag-number - ;
-: quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 3 bootstrap-cells object tag-number - ;
-
: jit-define ( quot rc rt offset name -- )
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! Bignums
-: bignum-bits bootstrap-cell-bits 2 - ;
+: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
-: bignum-radix bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
! Padded with fixnums for 8-byte alignment
-: t, t t-offset fixup ;
+: t, ( -- ) t t-offset fixup ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f tag-number ;
-: 0, 0 >bignum ' 0-offset fixup ;
-: 1, 1 >bignum ' 1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
+: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
+: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
! Words
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
+H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
"\""
"#!"
"("
+ "(("
":"
";"
"<PRIVATE"
\ flatten-class must-infer\r
\ flatten-builtin-class must-infer\r
\r
-: class= [ class<= ] [ swap class<= ] 2bi and ;\r
+: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;\r
\r
-: class-and* >r class-and r> class= ;\r
+: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
\r
-: class-or* >r class-or r> class= ;\r
+: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
\r
[ t ] [ object object object class-and* ] unit-test\r
[ t ] [ fixnum object fixnum class-and* ] unit-test\r
[ f ] [ null { number fixnum null } min-class ] unit-test\r
\r
! Test for hangs?\r
-: random-class classes random ;\r
+: random-class ( -- class ) classes random ;\r
\r
-: random-op\r
+: random-op ( -- word )\r
{\r
class-and\r
class-or\r
] unit-test\r
] times\r
\r
-: random-boolean\r
+: random-boolean ( -- ? )\r
{ t f } random ;\r
\r
-: boolean>class\r
+: boolean>class ( ? -- class )\r
object null ? ;\r
\r
-: random-boolean-op\r
+: random-boolean-op ( -- word )\r
{\r
and\r
or\r
xor\r
} random ;\r
\r
-: class-xor [ class-or ] 2keep class-and class-not class-and ;\r
+: class-xor ( cls1 cls2 -- cls3 )\r
+ [ class-or ] 2keep class-and class-not class-and ;\r
\r
-: boolean-op>class-op\r
+: boolean-op>class-op ( word -- word' )\r
{\r
{ and class-and }\r
{ or class-or }\r
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
-GENERIC: empty-union-test
+GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
-GENERIC: method-forget-test
+GENERIC: method-forget-test ( obj -- obj )
TUPLE: method-forget-class ;
M: method-forget-class method-forget-test ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
-: predicate-effect 1 { "?" } <effect> ;
+: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
M: word reset-class drop ;
-<PRIVATE
-
! update-map
: class-uses ( class -- seq )
[
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
+<PRIVATE
+
: update-map+ ( class -- )
dup class-uses update-map get add-vertex ;
: (define-class) ( word props -- )
>r
dup reset-class
+ dup class? [ dup new-class ] unless
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
M: class update-class drop ;
-GENERIC: update-methods ( assoc -- )
+GENERIC: update-methods ( class assoc -- )
: update-classes ( class -- )
- class-usages
- [ [ drop update-class ] assoc-each ]
+ dup class-usages
+ [ nip keys [ update-class ] each ]
[ update-methods ]
- bi ;
+ 2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences
-definitions combinators arrays accessors ;
+definitions combinators arrays assocs generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class rank-class drop 3 ;
: redefine-mixin-class ( class members -- )
- dupd define-union-class
- t "mixin" set-word-prop ;
+ [ (define-union-class) ]
+ [ drop t "mixin" set-word-prop ]
+ 2bi ;
: define-mixin-class ( class -- )
dup mixin-class? [
] unless ;
: if-mixin-member? ( class mixin true false -- )
- >r >r check-mixin-class 2dup members memq? r> r> if ; inline
+ [ check-mixin-class 2dup members memq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
- [ members swap bootstrap-word ] prepose keep
+ [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
+: update-classes/new ( mixin -- )
+ class-usages
+ [ keys [ update-class ] each ]
+ [ implementors [ make-generic ] each ] bi ;
+
: add-mixin-instance ( class mixin -- )
- [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
+ #! Note: we call update-classes on the new member, not the
+ #! mixin. This ensures that we only have to update the
+ #! methods whose specializer intersects the new member, not
+ #! the entire mixin (since the other mixin members are not
+ #! affected at all). Also, all usages of the mixin will get
+ #! updated by transitivity; the mixins usages appear in
+ #! class-usages of the member, now that it's been added.
+ [ 2drop ] [
+ [ [ suffix ] change-mixin-class ] 2keep drop
+ dup new-class? [ update-classes/new ] [ update-classes ] if
+ ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
- [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
+ [
+ [ [ swap remove ] change-mixin-class ] keep
+ update-classes
+ ] [ 2drop ] if-mixin-member? ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
IN: classes.tuple.tests
TUPLE: rect x y w h ;
-: <rect> rect boa ;
+: <rect> ( x y w h -- rect ) rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
PREDICATE: silly-pred < tuple
class \ rect = ;
-GENERIC: area
+GENERIC: area ( obj -- n )
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
[ 1 ] [ <t4> 1 m2 ] unit-test
! another combination issue
-GENERIC: silly
+GENERIC: silly ( obj -- obj obj )
UNION: my-union slice repetition column array vector reversed ;
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem new ;
-: cons-test-2 \ erg's-reshape-problem boa ;
+: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
+: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
-: test-laptop-slot-values
+: test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
-: test-server-slot-values
+: test-server-slot-values ( -- )
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
"a" "b" <test2> "test" set
-: test-a/b
+: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
-: test-move-up
+: test-move-up ( -- )
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;
2drop
[
[ update-tuples-after ]
- [ changed-definition ]
+ [ +inlined+ changed-definition ]
[ redefined ]
tri
] each-subclass
M: union-class update-class define-union-predicate ;
+: (define-union-class) ( class members -- )
+ f swap f union-class define-class ;
+
: define-union-class ( class members -- )
- [ f swap f union-class define-class ]
- [ drop update-classes ]
- 2bi ;
+ [ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
main-vocab-hook get [ call ] [ "listener" ] if*
] if ;
-: default-cli-args
+: default-cli-args ( -- )
global [
"quiet" off
"script" off
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
-: card-mark HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
-: float-offset 8 float tag-number - ;
-: string-offset 4 bootstrap-cells object tag-number - ;
-: profile-count-offset 7 bootstrap-cells object tag-number - ;
-: byte-array-offset 2 bootstrap-cells object tag-number - ;
-: alien-offset 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset bootstrap-cell object tag-number - ;
-: tuple-class-offset bootstrap-cell tuple tag-number - ;
-: class-hash-offset bootstrap-cell object tag-number - ;
-: word-xt-offset 8 bootstrap-cells object tag-number - ;
-: word-code-offset 9 bootstrap-cells object tag-number - ;
-: compiled-header-size 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ;
+: float-offset ( -- n ) 8 float tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: compiled-header-size ( -- n ) 4 bootstrap-cells ;
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
-: :errors +error+ compiler-errors. ;
+: :errors ( -- ) +error+ compiler-errors. ;
-: :warnings +warning+ compiler-errors. ;
+: :warnings ( -- ) +warning+ compiler-errors. ;
-: :linkage +linkage+ compiler-errors. ;
+: :linkage ( -- ) +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
! Some randomized tests
: compiled-fixnum* fixnum* ;
-: test-fixnum*
+: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
: compiled-fixnum>bignum fixnum>bignum ;
-: test-fixnum>bignum
+: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
: compiled-bignum>fixnum bignum>fixnum ;
-: test-bignum>fixnum
+: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def word-def [ { fixnum } declare ] prepend ;
+: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
--- /dev/null
+IN: compiler.tests
+USING: compiler tools.test math parser ;
+
+GENERIC: method-redefine-test ( a -- b )
+
+M: integer method-redefine-test 3 + ;
+
+: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+
+[ 6 ] [ method-redefine-test-1 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-1 ] unit-test
! Regression
-: empty ;
+: empty ( -- ) ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
-: dummy-if-1 t [ ] [ ] if ;
+: dummy-if-1 ( -- ) t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
-: dummy-if-2 f [ ] [ ] if ;
+: dummy-if-2 ( -- ) f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
-: dummy-if-3 t [ 1 ] [ 2 ] if ;
+: dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
-: dummy-if-4 f [ 1 ] [ 2 ] if ;
+: dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
-: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
+: dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
-: dummy-if-6
+: dummy-if-6 ( n -- n )
dup 1 fixnum<= [
drop 1
] [
[ 17 ] [ 10 dummy-if-6 ] unit-test
-: dead-code-rec
+: dead-code-rec ( -- obj )
t [
3.2
] [
[ 3.2 ] [ dead-code-rec ] unit-test
-: one-rec [ f one-rec ] [ "hi" ] if ;
+: one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
-: after-if-test
+: after-if-test ( -- n )
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
[ ] [ 10 countdown-b ] unit-test
-: dummy-when-1 t [ ] when ;
+: dummy-when-1 ( -- ) t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
-: dummy-when-2 f [ ] when ;
+: dummy-when-2 ( -- ) f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
-: dummy-when-3 dup [ dup fixnum* ] when ;
+: dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
-: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
+: dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
-: dummy-when-5 f [ dup fixnum* ] when ;
+: dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
-: dummy-unless-1 t [ ] unless ;
+: dummy-unless-1 ( -- ) t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
-: dummy-unless-2 f [ ] unless ;
+: dummy-unless-2 ( -- ) f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
-: dummy-unless-3 dup [ drop 3 ] unless ;
+: dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
] compile-call
] unit-test
-GENERIC: single-combination-test
+GENERIC: single-combination-test ( obj1 obj2 -- obj )
M: object single-combination-test drop ;
M: f single-combination-test nip ;
DEFER: single-combination-test-2
-: single-combination-test-4
+: single-combination-test-4 ( obj -- obj )
dup [ single-combination-test-2 ] when ;
-: single-combination-test-3
+: single-combination-test-3 ( obj -- obj )
drop 3 ;
-GENERIC: single-combination-test-2
+GENERIC: single-combination-test-2 ( obj -- obj )
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;
IN: compiler.tests
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
-words splitting sorting ;
+words splitting grouping sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
2 group flip first ;
-: foo 3 throw 7 ;
-: bar foo 4 ;
-: baz bar 5 ;
+: foo ( -- * ) 3 throw 7 ;
+: bar ( -- * ) foo 4 ;
+: baz ( -- * ) bar 5 ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
{ baz bar foo throw } tail?
] unit-test
-: bleh [ 3 + ] map [ 0 > ] filter ;
+: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-contains? symbolic-stack-trace memq? ;
+: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
-: quux { 1 2 3 } [ "hi" throw ] sort ;
+: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
-: foo ;
+: foo ( -- ) ;
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch
+: try-breaking-dispatch ( n a b -- a b str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
-: try-breaking-dispatch-2
+: try-breaking-dispatch-2 ( -- ? )
1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
[ t ] [
] unit-test
! Regression
-: foox
+: foox ( obj -- obj )
dup not
[ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
] unit-test
! Regression
-: a-dummy drop "hi" print ;
+: a-dummy ( -- ) drop "hi" print ;
[ ] [
1 [
] compile-call
] unit-test
-: float-spill-bug
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-definitions get keys [ word? ] filter
+ changed-definitions get [ drop word? ] assoc-filter
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
- ;
+ dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[
#! with a declaration.
f { object } declare ;
-: init-catchstack V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 setenv ;
PRIVATE>
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
-: %prologue-later \ %prologue-later , ;
+: %prologue-later ( -- ) \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
-: %epilogue-later \ %epilogue-later , ;
+: %epilogue-later ( -- ) \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt cpu ( -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
-HOOK: %gc cpu
+HOOK: %gc cpu ( -- )
: operand ( var -- op ) get v>operand ; inline
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
: jit-call-quot ( -- )\r
- temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt\r
+ temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt\r
temp-reg MTCTR ! jump to quotation-xt\r
BCTR ;\r
\r
temp-reg ds-reg 0 LWZ ! load index\r
temp-reg dup 1 SRAWI ! turn it into an array offset\r
quot-reg dup temp-reg ADD ! compute quotation location\r
- quot-reg dup array-start LWZ ! load quotation\r
+ quot-reg dup array-start-offset LWZ ! load quotation\r
ds-reg dup 4 SUBI ! pop index\r
jit-call-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return return-reg stack-reg rot [+] ;
+: load/store-int-return ( n reg-class -- src dst )
+ return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-: FSTP 4 = [ FSTPS ] [ FSTPL ] if ;
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
-: FLD 4 = [ FLDS ] [ FLDL ] if ;
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return reg-size >r stack@ r> ;
+: load/store-float-return ( n reg-class -- op size )
+ [ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
-: (%box-long-long)
+: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
M: x86.32 %box-long-long ( n func -- )
8 [
- >r (%box-long-long) r> f %alien-invoke
+ [ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
M: x86.32 %box-large-struct ( n size -- )
4 "double" c-type set-c-type-align
] unless
-: sse2? "Intrinsic" throw ;
+: sse2? ( -- ? ) "Intrinsic" throw ;
\ sse2? [
{ EAX EBX ECX EDX } [ PUSH ] each
generator.registers system layouts alien ;
IN: cpu.x86.allot
-: allot-reg
+: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
combinators compiler.constants math.order ;
IN: cpu.x86.architecture
-HOOK: ds-reg cpu
-HOOK: rs-reg cpu
-HOOK: stack-reg cpu
-HOOK: stack-save-reg cpu
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
-: stack@ stack-reg swap [+] ;
+: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
-HOOK: temp-reg-1 cpu
-HOOK: temp-reg-2 cpu
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ cpu
+HOOK: fixnum>slot@ cpu ( op -- )
-HOOK: prepare-division cpu
+HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size 4 cells ;
+: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
M: x86 %replace swap %peek ;
-: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ stack-reg \ stack-frame get rot - [+] ;
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
-: REGISTERS:
+: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
M: indirect extended? base>> extended? ;
-: canonicalize-EBP
+: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
- ] when drop ;
+ ] when ;
-: canonicalize-ESP
+: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
- dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
+ dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-: canonicalize ( indirect -- )
+: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
+ canonicalize-EBP canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect boa dup canonicalize ;
+ indirect boa canonicalize ;
-: reg-code "register" word-prop 7 bitand ;
+: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
-: indirect-base* base>> EBP or reg-code ;
+: indirect-base* ( op -- n ) base>> EBP or reg-code ;
-: indirect-index* index>> ESP or reg-code ;
+: indirect-index* ( op -- n ) index>> ESP or reg-code ;
-: indirect-scale* scale>> 0 or ;
+: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
-: 1, 1 n, ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
+: 1, ( n -- ) 1 n, ; inline
+: 4, ( n -- ) 4 n, ; inline
+: 2, ( n -- ) 2 n, ; inline
+: cell, ( n -- ) bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
[ nip operand-64? ]
} cond and ;
-: rex.r
+: rex.r ( m op -- n )
extended? [ BIN: 00000100 bitor ] when ;
-: rex.b
+: rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
index>> extended? [ BIN: 00000010 bitor ] when
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
-: opcode, dup array? [ % ] [ , ] if ;
+: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
-: immediate-operand-size-bit
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1 ( imm dst reg,rex.w,opcode -- )
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
-: immediate-fits-in-size-bit
+: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
! Control flow
GENERIC: JMP ( op -- )
-: (JMP) HEX: e9 , 0 4, rc-relative ;
+: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
-: (CALL) HEX: e8 , 0 4, rc-relative ;
+: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) extended-opcode, 0 4, rc-relative ;
+: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
-: JO HEX: 80 JUMPcc ;
-: JNO HEX: 81 JUMPcc ;
-: JB HEX: 82 JUMPcc ;
-: JAE HEX: 83 JUMPcc ;
-: JE HEX: 84 JUMPcc ; ! aka JZ
-: JNE HEX: 85 JUMPcc ;
-: JBE HEX: 86 JUMPcc ;
-: JA HEX: 87 JUMPcc ;
-: JS HEX: 88 JUMPcc ;
-: JNS HEX: 89 JUMPcc ;
-: JP HEX: 8a JUMPcc ;
-: JNP HEX: 8b JUMPcc ;
-: JL HEX: 8c JUMPcc ;
-: JGE HEX: 8d JUMPcc ;
-: JLE HEX: 8e JUMPcc ;
-: JG HEX: 8f JUMPcc ;
+: JO ( dst -- ) HEX: 80 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
+: JB ( dst -- ) HEX: 82 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
+: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
+: JA ( dst -- ) HEX: 87 JUMPcc ;
+: JS ( dst -- ) HEX: 88 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
+: JP ( dst -- ) HEX: 8a JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
+: JL ( dst -- ) HEX: 8c JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
+: JLE ( dst -- ) HEX: 8e JUMPcc ;
+: JG ( dst -- ) HEX: 8f JUMPcc ;
: LEAVE ( -- ) HEX: c9 , ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-: CDQ HEX: 99 , ;
-: CQO HEX: 48 , CDQ ;
+: CDQ ( -- ) HEX: 99 , ;
+: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
-: CMOVO HEX: 40 MOVcc ;
-: CMOVNO HEX: 41 MOVcc ;
-: CMOVB HEX: 42 MOVcc ;
-: CMOVAE HEX: 43 MOVcc ;
-: CMOVE HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE HEX: 45 MOVcc ;
-: CMOVBE HEX: 46 MOVcc ;
-: CMOVA HEX: 47 MOVcc ;
-: CMOVS HEX: 48 MOVcc ;
-: CMOVNS HEX: 49 MOVcc ;
-: CMOVP HEX: 4a MOVcc ;
-: CMOVNP HEX: 4b MOVcc ;
-: CMOVL HEX: 4c MOVcc ;
-: CMOVGE HEX: 4d MOVcc ;
-: CMOVLE HEX: 4e MOVcc ;
-: CMOVG HEX: 4f MOVcc ;
+: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
+: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
+: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
+: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
+: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
+: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
+: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
+: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
! CPU Identification
-: CPUID HEX: a2 extended-opcode, ;
+: CPUID ( -- ) HEX: a2 extended-opcode, ;
! x87 Floating Point Unit
arg0 \ f tag-number CMP ! compare it with f
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
- arg0 quot-xt@ [+] JMP ! jump to quotation-xt
+ arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
- arg0 arg0 array-start [+] MOV ! load quotation
- arg0 quot-xt@ [+] JMP ! execute branch
+ arg0 arg0 array-start-offset [+] MOV ! load quotation
+ arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
} define-intrinsic
! Slots
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" get operand-tag - [+] ;
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
-: %slot-any
+: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
{ +clobber+ { "offset" } }
} ;
-: define-getter
+: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
-: define-unsigned-getter
+: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
-: define-signed-getter
+: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
{ +clobber+ { "value" "offset" } }
} ;
-: define-setter
+: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template
: :vars ( -- )
error-continuation get continuation-name namestack. ;
-: :res ( n -- )
+: :res ( n -- * )
1- restarts get-global nth f restarts set-global restart ;
-: :1 1 :res ;
-: :2 2 :res ;
-: :3 3 :res ;
+: :1 ( -- * ) 1 :res ;
+: :2 ( -- * ) 2 :res ;
+: :3 ( -- * ) 3 :res ;
: restart. ( restart n -- )
[
: stack-overflow. ( obj name -- )
write " stack overflow" print drop ;
-: datastack-underflow. "Data" stack-underflow. ;
-: datastack-overflow. "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
+: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
+: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
+: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
+: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
-: memory-error.
+: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
-: primitive-error.
+: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
[ second 0 15 between? ]
} cond ;
-: kernel-errors
+: kernel-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
SYMBOL: changed-definitions
-: changed-definition ( defspec -- )
- dup changed-definitions get
- [ no-compilation-unit ] unless*
- set-at ;
+SYMBOL: +inlined+
+SYMBOL: +called+
+
+: changed-definition ( defspec how -- )
+ swap changed-definitions get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+SYMBOL: new-classes
+
+: new-class ( word -- )
+ dup new-classes get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+: new-class? ( word -- ? )
+ new-classes get key? ;
GENERIC: where ( defspec -- loc )
IN: effects
ARTICLE: "effect-declaration" "Stack effect declaration"
-"It is good practice to declare the stack effects of words using the following syntax:"
+"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
+$nl
+"Stack effects are declared with the following syntax:"
{ $code ": sq ( x -- y ) dup * ;" }
"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Stack effect declarations are read in using a parsing word:"
{ $subsection POSTPONE: ( }
ARTICLE: "effects" "Stack effects"
"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
$nl
+"Stack effects of words can be declared."
+{ $subsection "effect-declaration" }
"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
{ $subsection effect }
{ $subsection effect? }
-"Stack effects of words can be declared."
-{ $subsection "effect-declaration" }
+"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
+{ $subsection POSTPONE: (( }
"Getting a word's declared stack effect:"
{ $subsection stack-effect }
"Converting a stack effect to a string form:"
{ $subsection effect>string }
"Comparing effects:"
{ $subsection effect-height }
-{ $subsection effect<= } ;
+{ $subsection effect<= }
+{ $see-also "inference" } ;
ABOUT: "effects"
IN: effects.tests
-USING: effects tools.test ;
+USING: effects tools.test prettyprint accessors sequences ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 3 <effect> f effect<= ] unit-test
+[ 2 ] [ (( a b -- c )) in>> length ] unit-test
+[ 1 ] [ (( a b -- c )) out>> length ] unit-test
+
+
+[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
+[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
+[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
+[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
+[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
-combinators ;
+combinators accessors ;
IN: effects
TUPLE: effect in out terminated? ;
effect boa ;
: effect-height ( effect -- n )
- dup effect-out length swap effect-in length - ;
+ [ out>> length ] [ in>> length ] bi - ;
: effect<= ( eff1 eff2 -- ? )
{
- { [ dup not ] [ t ] }
- { [ over effect-terminated? ] [ t ] }
- { [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ over terminated?>> ] [ t ] }
+ { [ dup terminated?>> ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
: effect>string ( effect -- string )
[
"( " %
- dup effect-in stack-picture %
- "-- " %
- dup effect-out stack-picture %
- effect-terminated? [ "* " % ] when
+ [ in>> stack-picture % "-- " % ]
+ [ out>> stack-picture % ]
+ [ terminated?>> [ "* " % ] when ]
+ tri
")" %
] "" make ;
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
- [ effect-in clone ] keep effect-out clone <effect> ;
+ [ in>> clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- effect-in length cut* ;
+ in>> length cut* ;
: load-shuffle ( stack shuffle -- )
- effect-in [ set ] 2each ;
+ in>> [ set ] 2each ;
: shuffled-values ( shuffle -- values )
- effect-out [ get ] map ;
+ out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
: word-dataflow ( word -- effect dataflow )
[
- dup "no-effect" word-prop [ no-effect ] when
- dup "no-compile" word-prop [ no-effect ] when
+ dup "cannot-infer" word-prop [ cannot-infer-effect ] when
+ dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> f ds-loc boa ;
+: <ds-loc> ( n -- 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> f rs-loc boa ;
+: <rs-loc> ( n -- 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?
<PRIVATE
! Moving values between locations and registers
-: %move-bug "Bug in generator.registers" throw ;
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
-: (loc)
+: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
-GENERIC: generic-forget-test-2
+GENERIC: generic-forget-test-2 ( a b -- c )
M: sequence generic-forget-test-2 = ;
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
-GENERIC: generic-forget-test-3
+GENERIC: generic-forget-test-3 ( a -- b )
M: f generic-forget-test-3 ;
\ check-method boa throw
] unless ; inline
-: with-methods ( generic quot -- )
- swap [ "methods" word-prop swap call ] keep make-generic ;
+: affected-methods ( class generic -- seq )
+ "methods" word-prop swap
+ [ nip classes-intersect? ] curry assoc-filter
+ values ;
+
+: update-generic ( class generic -- )
+ [ affected-methods [ +called+ changed-definition ] each ]
+ [ make-generic ]
+ bi ;
+
+: with-methods ( class generic quot -- )
+ [ [ "methods" word-prop ] dip call ]
+ [ drop update-generic ] 3bi ;
inline
: method-word-name ( class word -- string )
M: method-body smart-usage
"method-generic" word-prop smart-usage ;
-: implementors* ( classes -- words )
+GENERIC: implementors ( class/classes -- seq )
+
+M: class implementors
+ all-words [ "methods" word-prop key? ] with filter ;
+
+M: assoc implementors
all-words [
- "methods" word-prop keys
+ "methods" word-prop keys
swap [ key? ] curry contains?
] with filter ;
-: implementors ( class -- seq )
- dup associate implementors* ;
-
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
]
[ call-next-method ] bi ;
-M: assoc update-methods ( assoc -- )
- implementors* [ make-generic ] each ;
+M: assoc update-methods ( class assoc -- )
+ implementors [ update-generic ] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
-: num-hi-tags num-types get num-tags get - ;
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
-: word-hashcode% [ 1 slot ] % ;
+: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
[
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
-: array-nth% 2 + , [ slot { word } declare ] % ;
+: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
prettyprint byte-vectors bit-vectors float-vectors definitions
generic sets graphs assocs ;
-GENERIC: lo-tag-test
+GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ;
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-GENERIC: hi-tag-test
+GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ;
C: <circle> circle
-GENERIC: area
+GENERIC: area ( shape -- n )
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-GENERIC: perimiter
+GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter + 2 * ;
+: rectangle-perimiter ( n -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
-: hypotenuse [ sq ] bi@ + sqrt ;
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-GENERIC: big-mix-test
+GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ;
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
-GENERIC: small-lo-tag
+GENERIC: small-lo-tag ( obj -- obj )
M: fixnum small-lo-tag drop "fixnum" ;
M: c funky* "c" , call-next-method ;
-: funky [ funky* ] { } make ;
+: funky ( obj -- seq ) [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
TUPLE: xref-tuple-1 ;
TUPLE: xref-tuple-2 < xref-tuple-1 ;
-: (xref-test) drop ;
+: (xref-test) ( obj -- ) drop ;
GENERIC: xref-test ( obj -- )
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
- [
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
+ [ <big-dispatch-engine> ]
+ bi engine>quot
]
} cleave
] with-scope ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax sequences strings ;
+IN: grouping
+
+ARTICLE: "grouping" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
+ABOUT: "grouping"
+
+HELP: groups
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
+{ $see-also group } ;
+
+HELP: group
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
+
+HELP: <groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences splitting ;"
+ "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ }
+} ;
+
+HELP: <sliced-groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences splitting ;"
+ "9 >array 3 <sliced-groups>"
+ "dup [ reverse-here ] each concat >array ."
+ "{ 2 1 0 5 4 3 8 7 6 }"
+ }
+} ;
+
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: splitting sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
--- /dev/null
+USING: grouping tools.test kernel sequences arrays ;
+IN: grouping.tests
+
+[ { 1 2 3 } 0 group ] must-fail
+
+[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2 <groups>
+ 2 over set-length
+ >array
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order strings arrays vectors sequences
+accessors ;
+IN: grouping
+
+TUPLE: abstract-groups seq n ;
+
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
+
+GENERIC: group@ ( n groups -- from to seq )
+
+M: abstract-groups nth group@ subseq ;
+
+M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+
+M: abstract-groups like drop { } like ;
+
+INSTANCE: abstract-groups sequence
+
+TUPLE: groups < abstract-groups ;
+
+: <groups> ( seq n -- groups )
+ groups new-groups ; inline
+
+M: groups length
+ [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+
+M: groups set-length
+ [ n>> * ] [ seq>> ] bi set-length ;
+
+M: groups group@
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+
+TUPLE: sliced-groups < groups ;
+
+: <sliced-groups> ( seq n -- groups )
+ sliced-groups new-groups ; inline
+
+M: sliced-groups nth group@ <slice> ;
+
+TUPLE: clumps < abstract-groups ;
+
+: <clumps> ( seq n -- clumps )
+ clumps new-groups ; inline
+
+M: clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+TUPLE: sliced-clumps < groups ;
+
+: <sliced-clumps> ( seq n -- clumps )
+ sliced-clumps new-groups ; inline
+
+M: sliced-clumps nth group@ <slice> ;
+
+: group ( seq n -- array ) <groups> { } like ;
+
+: clump ( seq n -- array ) <clumps> { } like ;
--- /dev/null
+Grouping sequence elements into subsequences
--- /dev/null
+collections
$nl
"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
{ $subsection <hash-array> }
-{ $subsection nth-pair }
{ $subsection set-nth-pair }
-{ $subsection find-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
{ $subsection rehash } ;
{ $values { "key" "a key" } { "hash" hashtable } { "array" "the underlying array of the hashtable" } { "n" "the index where the key would be stored" } { "empty?" "a boolean indicating whether the location is currently empty" } }
{ $description "Searches the hashtable for the key using a linear probing strategy. If the key is not present in the hashtable, outputs the index where it should be stored." } ;
-HELP: nth-pair
-{ $values { "n" "an index in the sequence" } { "seq" "a sequence" } { "key" "the first element of the pair" } { "value" "the second element of the pair" } }
-{ $description "Fetches the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." } ;
-
-{ nth-pair set-nth-pair } related-words
-
HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ;
-HELP: find-pair
-{ $values { "array" "an array of pairs" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key" } { "value" "the successful value" } { "?" "a boolean of whether there was success" } }
-{ $description "Applies a quotation to successive pairs in the array, yielding the first successful pair." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because passing an array of odd length can lead to memory corruption." } ;
-
HELP: reset-hash
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" hashtable } }
{ $description "Resets the underlying array of the hashtable to a new array with the given capacity. Removes all entries from the hashtable." }
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
- math.private sequences sequences.private vectors ;
+math.private sequences sequences.private vectors grouping ;
IN: hashtables
<PRIVATE
: new-key@ ( key hash -- array n empty? )
hash-array 2dup hash@ (new-key@) ; inline
-: nth-pair ( n seq -- key value )
- swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
- inline
-
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
[ rot hash-count+ set-nth-pair t ]
[ rot drop set-nth-pair f ] if ; inline
-: find-pair-next >r 2 fixnum+fast r> ; inline
-
-: (find-pair) ( quot i array -- key value ? )
- 2dup array-capacity eq? [
- 3drop f f f
- ] [
- 2dup array-nth tombstone? [
- find-pair-next (find-pair)
- ] [
- [ nth-pair rot call ] 3keep roll [
- nth-pair >r nip r> t
- ] [
- find-pair-next (find-pair)
- ] if
- ] if
- ] if ; inline
-
-: find-pair ( array quot -- key value ? )
- 0 rot (find-pair) ; inline
-
-: (rehash) ( hash array -- )
- [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
+: (rehash) ( hash alist -- )
+ swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
[ hash-count 3 fixnum*fast ]
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
: grow-hash ( hash -- )
- [ dup hash-array swap assoc-size 1+ ] keep
+ [ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
swap (rehash) ;
dup hash-count swap hash-deleted - ;
: rehash ( hash -- )
- dup hash-array
-
dup length ((empty)) <array> pick set-hash-array
+ dup >alist
+
over hash-array length ((empty)) <array> pick set-hash-array
0 pick set-hash-count
0 pick set-hash-deleted
(rehash) ;
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
-M: hashtable assoc-find ( hash quot -- key value ? )
- >r hash-array r> find-pair ;
+M: hashtable >alist
+ hash-array 2 <groups> [ first tombstone? not ] filter ;
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
-HELP: no-effect
+HELP: cannot-infer-effect
{ $values { "word" word } }
-{ $description "Throws a " { $link no-effect } " error." }
+{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: inline-word
{ $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
-HELP: no-recursive-declaration
-{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
+HELP: missing-effect
+{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
HELP: recursive-quotation-error
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
SYMBOL: visited
-: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
#call consume/produce
] if ;
-TUPLE: no-effect word ;
+TUPLE: cannot-infer-effect word ;
-: no-effect ( word -- * ) \ no-effect inference-warning ;
+: cannot-infer-effect ( word -- * )
+ \ cannot-infer-effect inference-warning ;
-TUPLE: effect-error word effect ;
+TUPLE: effect-error word inferred declared ;
-: effect-error ( word effect -- * )
+: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
+TUPLE: missing-effect word ;
+
+: effect-required? ( word -- ? )
+ {
+ { [ dup inline? ] [ drop f ] }
+ { [ dup deferred? ] [ drop f ] }
+ { [ dup crossref? not ] [ drop f ] }
+ [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ } cond ;
+
+: ?missing-effect ( word -- )
+ dup effect-required?
+ [ missing-effect inference-error ] [ drop ] if ;
+
: check-effect ( word effect -- )
- dup pick stack-effect effect<=
- [ 2drop ] [ effect-error ] if ;
+ over stack-effect {
+ { [ dup not ] [ 2drop ?missing-effect ] }
+ { [ 2dup effect<= ] [ 3drop ] }
+ [ effect-error ]
+ } cond ;
: finish-word ( word -- )
current-effect
finish-word
current-effect
] with-scope
- ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
+ ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
: apply-word ( word -- )
{
{ [ dup "infer" word-prop ] [ custom-infer ] }
- { [ dup "no-effect" word-prop ] [ no-effect ] }
+ { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
[ dup infer-word make-call-node ]
} cond ;
-TUPLE: no-recursive-declaration word ;
-
-: declared-infer ( word -- )
+: declared-infer ( word -- )
dup stack-effect [
make-call-node
] [
- \ no-recursive-declaration inference-error
+ \ missing-effect inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
-: inlined-block? "inlined-block" word-prop ;
+: inlined-block? ( word -- ? )
+ "inlined-block" word-prop ;
-: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
+: <inlined-block> ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- #label data )
[
namespace swap update ;
: current-stack-height ( -- n )
- meta-d get length d-in get - ;
+ d-in get meta-d get length - ;
: word-stack-height ( word -- n )
- stack-effect [ in>> length ] [ out>> length ] bi - ;
+ stack-effect effect-height ;
: bad-recursive-declaration ( word inferred -- )
- dup 0 < [ 0 ] [ 0 swap ] if <effect> effect-error ;
+ dup 0 < [ 0 swap ] [ 0 ] if <effect>
+ over stack-effect
+ effect-error ;
: check-stack-height ( word height -- )
over word-stack-height over =
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
! We don't want to use = to compare literals
-: foo reverse ;
+: foo ( seq -- seq' ) reverse ;
\ foo [
[
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
-: `input node get in-d>> nth ;
-: `output node get out-d>> nth ;
-: class, <class-constraint> , ;
-: literal, <literal-constraint> , ;
-: interval, <interval-constraint> , ;
+: `input ( n -- value ) node get in-d>> nth ;
+: `output ( n -- value ) node get out-d>> nth ;
+: class, ( class value -- ) <class-constraint> , ;
+: literal, ( literal value -- ) <literal-constraint> , ;
+: interval, ( interval value -- ) <interval-constraint> , ;
M: f apply-constraint drop ;
IN: inference.dataflow
! Computed value
-: <computed> \ <computed> counter ;
+: <computed> ( -- value ) \ <computed> counter ;
! Literal value
TUPLE: value < identity-tuple literal uid recursion ;
: r-tail ( n -- seq )
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
-: node-child node-children first ;
+: node-child ( node -- child ) node-children first ;
TUPLE: #label < node word loop? returns calls ;
SYMBOL: node-stack
-: >node node-stack get push ;
-: node> node-stack get pop ;
-: node@ node-stack get peek ;
+: >node ( node -- ) node-stack get push ;
+: node> ( -- node ) node-stack get pop ;
+: node@ ( -- node ) node-stack get peek ;
: iterate-next ( -- node ) node@ successor>> ;
sequences prettyprint io words arrays inspector effects debugger
assocs accessors ;
+M: inference-error error-help error>> error-help ;
+
M: inference-error error.
dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
swap error>> error. "Nesting: " write . ;
-M: inference-error error-help drop f ;
-
M: unbalanced-branches-error error.
"Unbalanced branches:" print
[ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
drop
"Quotation pops retain stack elements which it did not push" ;
-M: no-effect error.
+M: cannot-infer-effect error.
"Unable to infer stack effect of " write word>> . ;
-M: no-recursive-declaration error.
- "The recursive word " write
+M: missing-effect error.
+ "The word " write
word>> pprint
" must declare a stack effect" print ;
M: effect-error error.
"Stack effects of the word " write
- dup word>> pprint
- " do not match." print
- "Declared: " write
- dup word>> stack-effect effect>string .
- "Inferred: " write effect>> effect>string . ;
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> effect>string . ]
+ [ "Declared: " write declared>> effect>string . ] tri ;
M: recursive-quotation-error error.
"The quotation " write
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
-{ $subsection no-effect }
+{ $subsection cannot-infer-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
-{ $subsection no-recursive-declaration } ;
+{ $subsection missing-effect } ;
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."
{ $subsection "inference-limitations" }
{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
-{ $subsection "compiler-transforms" } ;
+{ $subsection "compiler-transforms" }
+{ $see-also "effects" } ;
ABOUT: "inference"
] must-fail
! Test inference of termination of control flow
-: termination-test-1
- "foo" throw ;
+: termination-test-1 ( -- * ) "foo" throw ;
-: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
+: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] must-infer-as
-: infinite-loop infinite-loop ;
-
-[ [ infinite-loop ] infer ] must-fail
-
-: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] must-fail
-
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
{ 0 1 } [ sym-test ] must-infer-as
-: terminator-branch
+: terminator-branch ( a -- b )
dup [
length
] [
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
-: bad-input#
+{ 2 2 } [
dup string? [ 2array throw ] unless
- over string? [ 2array throw ] unless ;
-
-{ 2 2 } [ bad-input# ] must-infer-as
+ over string? [ 2array throw ] unless
+] must-infer-as
! Regression
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
-MATH: xyz
+MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx fooxxx ;
+: barxxx ( a b -- c ) fooxxx ;
[ [ barxxx ] infer ] must-fail
DEFER: deferred-word
-: calls-deferred-word [ deferred-word ] [ 3 ] if ;
-
-{ 1 1 } [ calls-deferred-word ] must-infer-as
+{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
USE: inference.dataflow
[ [ erg's-inference-bug ] infer ] must-fail
-: inference-invalidation-a ;
-: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline
-: inference-invalidation-c [ + ] inference-invalidation-b ;
-
-[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-
-{ 2 1 } [ inference-invalidation-c ] must-infer-as
-
-[ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
-
-[ 3 ] [ inference-invalidation-c ] unit-test
-
-{ 0 1 } [ inference-invalidation-c ] must-infer-as
-
-GENERIC: inference-invalidation-d ( obj -- )
-
-M: object inference-invalidation-d inference-invalidation-c 2drop ;
-
-\ inference-invalidation-d must-infer
-
-[ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
-
-[ [ inference-invalidation-d ] infer ] must-fail
+! : inference-invalidation-a ( -- );
+! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
+!
+! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+!
+! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+!
+! [ 3 ] [ inference-invalidation-c ] unit-test
+!
+! { 0 1 } [ inference-invalidation-c ] must-infer-as
+!
+! GENERIC: inference-invalidation-d ( obj -- )
+!
+! M: object inference-invalidation-d inference-invalidation-c 2drop ;
+!
+! \ inference-invalidation-d must-infer
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+!
+! [ [ inference-invalidation-d ] infer ] must-fail
: forget-errors ( -- )
all-words [
- dup subwords [ f "no-effect" set-word-prop ] each
- f "no-effect" set-word-prop
+ dup subwords [ f "cannot-infer" set-word-prop ] each
+ f "cannot-infer" set-word-prop
] each ;
\ (set-os-envs) { array } { } <effect> set-primitive-effect
-\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
IN: inference.state.tests
-USING: tools.test inference.state words kernel namespaces ;
+USING: tools.test inference.state words kernel namespaces
+definitions ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel words ;
+USING: assocs namespaces sequences kernel definitions ;
IN: inference.state
! Nesting state to solve recursion
! Compile-time data stack
SYMBOL: meta-d
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
+: push-d ( obj -- ) meta-d get push ;
+: pop-d ( -- obj ) meta-d get pop ;
+: peek-d ( -- obj ) meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
+: push-r ( obj -- ) meta-r get push ;
+: pop-r ( -- obj ) meta-r get pop ;
+: peek-r ( -- obj ) meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph
quotations inference accessors combinators words arrays
classes ;
-: compose-n-quot <repetition> >quotation ;
-: compose-n compose-n-quot call ;
+: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
+: compose-n ( quot -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
-: compose-n-test 2 \ + compose-n ;
+: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ new must-infer
-
-TUPLE: a-tuple x y z ;
-
-: set-slots-test ( x y z -- )
- { set-a-tuple-x set-a-tuple-y } set-slots ;
-
-\ set-slots-test must-infer
-
-: set-slots-test-2
- { set-a-tuple-x set-a-tuple-x } set-slots ;
-
-[ [ set-slots-test-2 ] infer ] must-fail
-
TUPLE: color r g b ;
C: <color> color
-: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+: cleave-test ( color -- r g b )
+ { [ r>> ] [ g>> ] [ b>> ] } cleave ;
{ 1 3 } [ cleave-test ] must-infer-as
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
-: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
-: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
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 sets ;
+inspector hashtables classes generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
\ exists? must-infer
\ (exists?) must-infer
+\ file-info must-infer
+\ link-info must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
delete-file
] if ;
-: to-directory over file-name append-path ;
+: to-directory ( from to -- from to' )
+ over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
-: find-last-sep swap [ memq? ] curry find-last drop ;
+: find-last-sep ( seq seps -- n )
+ swap [ memq? ] curry find-last drop ;
M: growable stream-read-until
[ find-last-sep ] keep over [
: a 1 ; inline
: b 2 ; inline
-: foo { a b } flags ;
+: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
USING: arrays kernel math sequences words ;
IN: math.bitfields
-GENERIC: (bitfield) inline
+GENERIC: (bitfield) ( value accum shift -- newaccum )
M: integer (bitfield) ( value accum shift -- newaccum )
swapd shift bitor ;
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
-: ratio>float [ >bignum ] bi@ /f ;
+: ratio>float ( a b -- f ) [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
-: random-integer
+: random-integer ( -- n )
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;
{ 3 [ (a,b] ] }
} case ;
-: random-op
+: random-op ( -- pair )
{
{ + interval+ }
{ - interval- }
] when
random ;
-: interval-test
+: interval-test ( -- ? )
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
-: random-comparison
+: random-comparison ( -- pair )
{
{ < interval< }
{ <= interval<= }
{ >= interval>= }
} random ;
-: comparison-test
+: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [
C: <interval> interval
-: open-point f 2array ;
+: open-point ( n -- endpoint ) f 2array ;
-: closed-point t 2array ;
+: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ;
[ interval-to ] bi@ =
and and ;
-: (interval<) over interval-from over interval-from endpoint< ;
+: (interval<) ( i1 i2 -- i1 i2 ? )
+ over interval-from over interval-from endpoint< ;
: interval< ( i1 i2 -- ? )
{
SYMBOL: radix
SYMBOL: negative?
-: sign negative? get "-" "+" ? ;
+: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
} cond
] if ;
-: fold-if-branch? dup node-in-d first known-boolean-value? ;
+: fold-if-branch? ( node -- value ? )
+ dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
-: lift-branch
+: lift-branch ( node tail -- )
over
last-node clone-node
dup node-in-d \ #merge out-node
optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private ;
+optimizer.control kernel.private definitions ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
[ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup [
- over +inlined+ depends-on
- swap method 1quotation f splice-quot
- ] [
- 3drop t
- ] if ;
+ 2dup dispatching-class dup
+ [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
! regression
GENERIC: void-generic ( obj -- * )
-: breakage "hi" void-generic ;
+: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail
! another regression
: constant-branch-fold-0 "hey" ; foldable
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
-: bar foo 4 4 = and ;
+: bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test
! ensure identities are working in some form
] unit-test
! compiling <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
+: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
-: should-inline? method flat-length 10 <= ;
+: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression
-: lift-throw-tail-regression
+: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
-: generic-inline-test-1
+: generic-inline-test-1 ( -- x )
1
generic-inline-test
generic-inline-test
HINTS: recursive-inline-hang array ;
-: recursive-inline-hang-1
+: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
-: member-test { + - * / /i } member? ;
+: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
ABOUT: "parser"
-: $parsing-note
+: $parsing-note ( children -- )
drop
"This word should only be called from parsing words."
$notes ;
{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
HELP: parse-effect
-{ $values { "effect" "an instance of " { $link effect } } }
+{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
{ $description "Parses a stack effect from the current input line." }
-{ $examples "This word is used by " { $link POSTPONE: ( } " to parse stack effect declarations." }
+{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
$parsing-note ;
HELP: parse-base
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
+M: parsing-word stack-effect drop (( parsed -- parsed )) ;
+
: unexpected-eof ( word -- * ) f unexpected ;
: (parse-tokens) ( accum end -- accum )
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
- [ changed-definitions get key? [ staging-violation ] when ]
- [ execute ]
- bi ;
+ dup changed-definitions get key? [ staging-violation ] when
+ execute ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
- { [ dup parsing? ] [ nip execute-parsing t ] }
+ { [ dup parsing-word? ] [ nip execute-parsing t ] }
[ pick push drop t ]
} cond ;
lexer-factory get call (parse-lines) ;
! Parsing word utilities
-: parse-effect ( -- effect )
- ")" parse-tokens "(" over member? [
- "Stack effect declaration must not contain (" throw
- ] [
+: parse-effect ( end -- effect )
+ parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
] if
+ ] [
+ "Stack effect declaration must not contain ( or ((" throw
] if ;
ERROR: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE-WORD parse-definition ;
+: (:) ( -- word def ) CREATE-WORD parse-definition ;
SYMBOL: current-class
SYMBOL: current-generic
r> call
] with-scope ; inline
-: (M:)
+: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
- scan-word dup parsing?
+ scan-word dup parsing-word?
[ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
-float-arrays ;
+float-arrays combinators ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
+M: effect pprint* effect>string "(" swap ")" 3append text ;
+
: ?effect-height ( word -- n )
stack-effect [ effect-height ] [ 0 ] if* ;
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
- dup presented set
- dup parsing? over delimiter? rot t eq? or or
- [ bold font-style set ] when
+ [ presented set ]
+ [
+ [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
+ [ bold font-style set ] when
+ ] bi
] bind
] keep ;
<block swap pprint-word call block> ; inline
M: word pprint*
- dup parsing? [
+ dup parsing-word? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
- dup "break-before" word-prop line-break
- dup pprint-word
- dup ?start-group dup ?end-group
- "break-after" word-prop line-break
+ {
+ [ "break-before" word-prop line-break ]
+ [ pprint-word ]
+ [ ?start-group ]
+ [ ?end-group ]
+ [ "break-after" word-prop line-break ]
+ } cleave
] if ;
M: real pprint* number>string text ;
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
-
-[ "( a b -- c d )" ] [
- { "a" "b" } { "c" "d" } <effect> effect>string
-] unit-test
-
-[ "( -- c d )" ] [
- { } { "c" "d" } <effect> effect>string
-] unit-test
-
-[ "( a b -- )" ] [
- { "a" "b" } { } <effect> effect>string
-] unit-test
-
-[ "( -- )" ] [
- { } { } <effect> effect>string
-] unit-test
-
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ ] [ \ fixnum see ] unit-test
USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
-prettyprint.config sorting splitting math.parser vocabs
+prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
-combinators quotations sets ;
+combinators quotations sets accessors ;
: make-pprint ( obj quot -- block in use )
[
definer drop pprint-word ;
: stack-effect. ( word -- )
- dup parsing? over symbol? or not swap stack-effect and
+ [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
: word-synopsis ( word -- )
- dup seeing-word
- dup definer.
- dup pprint-word
- stack-effect. ;
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ stack-effect. ]
+ } cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup dispatch# pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ dispatch# pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "combination" word-prop hook-combination-var pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ "combination" word-prop hook-combination-var pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
- dup dup
- definer.
- "method-class" word-prop pprint-word
- "method-generic" word-prop pprint-word ;
+ [ definer. ]
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
- dup definer.
- dup mixin-instance-class pprint-word
- mixin-instance-mixin pprint-word ;
+ [ definer. ]
+ [ class>> pprint-word ]
+ [ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
POSTPONE: flushable
} [ declaration. ] with each ;
-: pprint-; \ ; pprint-word ;
+: pprint-; ( -- ) \ ; pprint-word ;
: (see) ( spec -- )
<colon dup synopsis*
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
-: (<block) pprinter-stack get push ;
+: (<block) ( block -- ) pprinter-stack get push ;
-: <block f <block> (<block) ;
+: <block ( -- ) f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
SYMBOL: prev
SYMBOL: next
-: split-groups [ t , ] when ;
+: split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;
[ compose-first length ]
[ compose-second length ] bi + ;
-M: compose nth
+M: compose virtual-seq compose-first ;
+
+M: compose virtual@
2dup compose-first length < [
compose-first
] [
[ compose-first length - ] [ compose-second ] bi
- ] if nth ;
+ ] if ;
-INSTANCE: compose immutable-sequence
+INSTANCE: compose virtual-sequence
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
+{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
$low-level-note ;
-HELP: reader-effect
-{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
-
HELP: define-reader
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: writer-effect
-{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
-
HELP: define-writer
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
-: reader-effect T{ effect f { "object" } { "value" } } ; inline
-
: reader-word ( name -- word )
- ">>" append reader-effect create-accessor ;
+ ">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
-: writer-effect T{ effect f { "value" "object" } { } } ; inline
-
: writer-word ( name -- word )
- "(>>" swap ")" 3append writer-effect create-accessor ;
+ "(>>" swap ")" 3append (( value object -- )) create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
-: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
-
: setter-word ( name -- word )
- ">>" prepend setter-effect create-accessor ;
+ ">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
-: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
-
: changer-word ( name -- word )
- "change-" prepend changer-effect create-accessor ;
+ "change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
USING: help.markup help.syntax sequences strings ;
IN: splitting
-ARTICLE: "groups-clumps" "Groups and clumps"
-"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
-"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
-"The difference can be summarized as the following:"
-{ $list
- { "With groups, the subsequences form the original sequence when concatenated:"
- { $unchecked-example "dup n groups concat sequence= ." "t" }
- }
- { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
- { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
- }
-} ;
-
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
{ $subsection split1 }
{ $subsection split }
"Splitting a string into lines:"
-{ $subsection string-lines }
-{ $subsection "groups-clumps" } ;
+{ $subsection string-lines } ;
ABOUT: "sequences-split"
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
-HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
-{ $see-also group } ;
-
-HELP: group
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
-{ $examples
- { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
-} ;
-
-HELP: <groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- { $example
- "USING: arrays kernel prettyprint sequences splitting ;"
- "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
- }
-} ;
-
-HELP: <sliced-groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- { $example
- "USING: arrays kernel prettyprint sequences splitting ;"
- "9 >array 3 <sliced-groups>"
- "dup [ reverse-here ] each concat >array ."
- "{ 2 1 0 5 4 3 8 7 6 }"
- }
-} ;
-
-HELP: clumps
-{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
-
-HELP: clump
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
-{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
-{ $examples
- { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
-} ;
-
-HELP: <clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- "Running averages:"
- { $example
- "USING: splitting sequences math prettyprint kernel ;"
- "IN: scratchpad"
- ": share-price"
- " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
- ""
- "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
- "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
- }
-} ;
-
-HELP: <sliced-clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
-
-{ clumps groups } related-words
-
-{ clump group } related-words
-
-{ <clumps> <groups> } related-words
-
-{ <sliced-clumps> <sliced-groups> } related-words
-
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " starts with " { $snippet "begin" } ". If there is a match, outputs the subrange of " { $snippet "seq" } " excluding " { $snippet "begin" } ", and " { $link t } ". If there is no match, outputs " { $snippet "seq" } " and " { $link f } "." } ;
USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
-[ { 1 2 3 } 0 group ] must-fail
-
-[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
-
[ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
[ "hello" "world-+." ] [ "hello-+world-+." "-+" split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
-
-[ { V{ "a" "b" } V{ f f } } ] [
- V{ "a" "b" } clone 2 <groups>
- 2 over set-length
- >array
-] unit-test
sets math.order accessors ;
IN: splitting
-TUPLE: abstract-groups seq n ;
-
-: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
-
-: construct-groups ( seq n class -- groups )
- >r check-groups r> boa ; inline
-
-GENERIC: group@ ( n groups -- from to seq )
-
-M: abstract-groups nth group@ subseq ;
-
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
-
-M: abstract-groups like drop { } like ;
-
-INSTANCE: abstract-groups sequence
-
-TUPLE: groups < abstract-groups ;
-
-: <groups> ( seq n -- groups )
- groups construct-groups ; inline
-
-M: groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
-
-M: groups set-length
- [ n>> * ] [ seq>> ] bi set-length ;
-
-M: groups group@
- [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-
-TUPLE: sliced-groups < groups ;
-
-: <sliced-groups> ( seq n -- groups )
- sliced-groups construct-groups ; inline
-
-M: sliced-groups nth group@ <slice> ;
-
-TUPLE: clumps < abstract-groups ;
-
-: <clumps> ( seq n -- clumps )
- clumps construct-groups ; inline
-
-M: clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
-
-M: clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
- [ n>> over + ] [ seq>> ] bi ;
-
-TUPLE: sliced-clumps < groups ;
-
-: <sliced-clumps> ( seq n -- clumps )
- sliced-clumps construct-groups ; inline
-
-M: sliced-clumps nth group@ <slice> ;
-
-: group ( seq n -- array ) <groups> { } like ;
-
-: clump ( seq n -- array ) <clumps> { } like ;
-
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;
{ $notes "This word is used inside parsing words to delegate further action to another parsing word, and to refer to parsing words literally from literal arrays and such." } ;
HELP: :
-{ $syntax ": word definition... ;" }
+{ $syntax ": word ( stack -- effect ) definition... ;" }
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
-{ $description "Defines a word in the current vocabulary." }
+{ $description "Defines a word with the given stack effect in the current vocabulary. The stack effect is optional for words which only push literals on the stack." }
{ $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ;
{ POSTPONE: : POSTPONE: ; define } related-words
{ $syntax "( inputs -- outputs )" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
-{ $notes "Recursive words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
+{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
+
+HELP: ((
+{ $syntax "(( inputs -- outputs ))" }
+{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
+{ $description "Literal stack effect syntax." }
+{ $notes "Useful for meta-programming with " { $link define-declared } "." }
+{ $examples
+ { $code
+ "SYMBOL: my-dynamic-word"
+ "USING: math random words ;"
+ "3 { [ + ] [ - ] [ * ] [ / ] } random curry"
+ "(( x -- y )) define-declared"
+ }
+} ;
HELP: !
{ $syntax "! comment..." }
] define-syntax
"(" [
- parse-effect word
+ ")" parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
] define-syntax
+ "((" [
+ "))" parse-effect parsed
+ ] define-syntax
+
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
: thread-registered? ( thread -- ? )
id>> threads key? ;
-: check-unregistered
+: check-unregistered ( thread -- thread )
dup thread-registered?
[ "Thread already stopped" throw ] when ;
-: check-registered
+: check-registered ( thread -- thread )
dup thread-registered?
[ "Thread is not running" throw ] unless ;
SYMBOL: load-help?
-: source-was-loaded t swap set-vocab-source-loaded? ;
+: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ;
-: source-wasn't-loaded f swap set-vocab-source-loaded? ;
+: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ;
: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
[ vocab-source-path [ bootstrap-file ] when* ] keep
source-was-loaded ;
-: docs-were-loaded t swap set-vocab-docs-loaded? ;
+: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ;
-: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
+: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ;
: load-docs ( vocab -- )
load-help? get [
{ $values { "word" word } { "target" word } }
{ $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ;
-HELP: parsing?
+HELP: parsing-word?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
dup compiled-unxref
compiled-crossref get delete-at ;
-SYMBOL: +inlined+
-SYMBOL: +called+
-
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
-: compiled-usages ( words -- seq )
- [ unique dup ] keep [
- compiled-usage [ nip +inlined+ eq? ] assoc-filter update
- ] with each keys ;
+: compiled-usages ( assoc -- seq )
+ clone [
+ dup [
+ [
+ [ compiled-usage ] dip
+ +inlined+ eq? [
+ [ nip +inlined+ eq? ] assoc-filter
+ ] when
+ ] dip swap update
+ ] curry assoc-each
+ ] keep keys ;
GENERIC: redefined ( word -- )
over unxref
over redefined
over set-word-def
- dup changed-definition
+ dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
-: parsing? ( obj -- ? )
- dup word? [ "parsing" word-prop ] [ drop f ] if ;
+PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
M: word literalize <wrapper> ;
-: ?word-name dup word? [ word-name ] when ;
+: ?word-name ( word -- name ) dup word? [ word-name ] when ;
: xref-words ( -- ) all-words [ xref ] each ;
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element new ;
+: <element> ( -- element ) element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
USING: kernel math sequences namespaces io.binary splitting
- strings hashtables ;
+grouping strings hashtables ;
IN: base64
<PRIVATE
USING: math kernel continuations ;
IN: benchmark.continuations
-: continuations-main
+: continuations-main ( -- )
100000 [ drop [ continue ] callcc0 ] each-integer ;
MAIN: continuations-main
-USING: namespaces math sequences splitting kernel columns ;
+USING: namespaces math sequences splitting grouping
+kernel columns ;
IN: benchmark.dispatch2
-: sequences
+: sequences ( -- seq )
[
1 ,
10 >bignum ,
1 [ + ] curry ,
] { } make ;
-: don't-flush-me drop ;
+: don't-flush-me ( obj -- ) drop ;
-: dispatch-test
+: dispatch-test ( -- )
1000000 sequences
[ [ 0 swap nth don't-flush-me ] each ] curry times ;
-USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax columns ;
+USING: sequences math mirrors splitting grouping
+kernel namespaces assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
M: object g drop "object" ;
-: objects
+: objects ( -- seq )
[
H{ } ,
\ + <mirror> ,
ALIEN: 1234 ,
] { } make ;
-: dispatch-test
+: dispatch-test ( -- )
2000000 objects [ [ g drop ] each ] curry times ;
MAIN: dispatch-test
sequences.private ;
IN: benchmark.dispatch4
-: foobar-1
+: foobar-1 ( n -- val )
dup {
[ 0 eq? [ 0 ] [ "x" ] if ]
[ 1 eq? [ 1 ] [ "x" ] if ]
[ 19 eq? [ 19 ] [ "x" ] if ]
} dispatch ;
-: foobar-2
+: foobar-2 ( n -- val )
{
{ [ dup 0 eq? ] [ drop 0 ] }
{ [ dup 1 eq? ] [ drop 1 ] }
{ [ dup 19 eq? ] [ drop 19 ] }
} cond ;
-: foobar-test-1
+: foobar-test-1 ( -- )
20000000 [
20 [
foobar-1 drop
] each
] times ;
-: foobar-test-2
+: foobar-test-2 ( -- )
20000000 [
20 [
foobar-2 drop
] ;
-: run-fasta 2500000 reverse-complement-in fasta ;
+: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
MAIN: run-fasta
swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
] if ;
-: fib-main 34 fast-fixnum-fib 9227465 assert= ;
+: fib-main ( -- ) 34 fast-fixnum-fib 9227465 assert= ;
MAIN: fib-main
1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+
] if ;
-: fib-main 34 fixnum-fib 9227465 assert= ;
+: fib-main ( -- ) 34 fixnum-fib 9227465 assert= ;
MAIN: fib-main
: fib ( m -- n )
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
-: fib-main 34 fib 9227465 assert= ;
+: fib-main ( -- ) 34 fib 9227465 assert= ;
MAIN: fib-main
swap box-i swap box-i + <box>
] if ;
-: fib-main T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
+: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
MAIN: fib-main
] if
] with-scope ;
-: fib-main 30 namespace-fib 1346269 assert= ;
+: fib-main ( -- ) 30 namespace-fib 1346269 assert= ;
MAIN: fib-main
IN: benchmark.fib6\r
USING: math kernel alien ;\r
\r
-: fib\r
+: fib ( x -- y )\r
"int" { "int" } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
1- dup fib swap 1- fib +\r
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main 25 fib drop ;\r
+: fib-main ( -- ) 25 fib drop ;\r
\r
MAIN: fib-main\r
: <range> ( from to -- seq ) dup <slice> ; inline
-: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
-: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ;
-: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ;
-: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
-: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
-: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ;
+: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
+: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
+: string-iter ( -- ) 100 [ 0 100000 <range> >string [ ] map drop ] times ;
+: sbuf-iter ( -- ) 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
+: reverse-iter ( -- ) 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
+: dot-iter ( -- ) 100 [ 0 100000 <range> dup v. drop ] times ;
-: iter-main
+: iter-main ( -- )
vector-iter
array-iter
string-iter
: ppm-header ( w h -- )
"P6\n" % swap # " " % # "\n255\n" % ;
-: buf-size width height * 3 * 100 + ;
+: buf-size ( -- n ) width height * 3 * 100 + ;
: mandel ( -- data )
[
dup 1- 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
-: nsieve-bits-main* 11 nsieve-bits-main ;
+: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
MAIN: nsieve-bits-main*
dup 1 - 2^ 10000 * nsieve.
2 - 2^ 10000 * nsieve. ;
-: nsieve-main* 9 nsieve-main ;
+: nsieve-main* ( -- ) 9 nsieve-main ;
MAIN: nsieve-main*
] with each
] tabular-output ;
-: partial-sums-main 2500000 partial-sums ;
+: partial-sums-main ( -- ) 2500000 partial-sums ;
MAIN: partial-sums-main
USING: io.files io.encodings.ascii random math.parser io math ;
IN: benchmark.random
-: random-numbers-path "random-numbers.txt" temp-file ;
+: random-numbers-path ( -- path )
+ "random-numbers.txt" temp-file ;
: write-random-numbers ( n -- )
random-numbers-path ascii [
[ [ oversampling sq / pgm-pixel ] each ] each
] B{ } make ;
-: raytracer-main
+: raytracer-main ( -- )
run "raytracer.pnm" temp-file binary set-file-contents ;
MAIN: raytracer-main
HINTS: recursive fixnum ;
-: recursive-main 11 recursive ;
+: recursive-main ( -- ) 11 recursive ;
MAIN: recursive-main
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
-hints unicode.case continuations io.encodings.ascii ;
+grouping hints unicode.case continuations io.encodings.ascii ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
] with-file-reader
] with-file-writer ;
-: reverse-complement-in
+: reverse-complement-in ( -- path )
"reverse-complement-in.txt" temp-file ;
-: reverse-complement-out
+: reverse-complement-out ( -- path )
"reverse-complement-out.txt" temp-file ;
: reverse-complement-main ( -- )
: number-of-requests 1 ;
-: server-addr "127.0.0.1" 7777 <inet4> ;
+: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- )
dup accept drop [
io.files io.encodings.ascii ;
IN: benchmark.sort
-: sort-benchmark
+: sort-benchmark ( -- )
random-numbers-path
ascii file-lines [ string>number ] map
natural-sort drop ;
TUPLE: hello n ;
-: foo 0 100000000 [ over hello-n + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- value ) dup tuple? [ 3 slot ] [ 3 throw ] if ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- val ) dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* 3 slot ;
+: hello-n* ( obj -- val ) 3 slot ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
>ranges filter-pad [ define-setters ] 2keep define-accessors
] with-compilation-unit ;
-: parse-bitfield
+: parse-bitfield ( -- )
scan ";" parse-tokens parse-slots define-bitfield ;
: BITFIELD:
parser vocabs.loader ;
IN: bootstrap.help
-: load-help
+: load-help ( -- )
"alien.syntax" require
"compiler" require
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
-: checksums "checksums.txt" temp-file ;
+: checksums ( -- temp ) "checksums.txt" temp-file ;
-: boot-image-names images [ boot-image-name ] map ;
+: boot-image-names ( -- seq ) images [ boot-image-name ] map ;
: compute-checksums ( -- )
checksums ascii [
ascii [ parse-model ] with-file-reader
[ normals ] 2keep 3array ;
-: model-path "bun_zipper.ply" temp-file ;
+: model-path ( -- path ) "bun_zipper.ply" temp-file ;
-: model-url "http://factorcode.org/bun_zipper.ply" ;
+: model-url ( -- url ) "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path )
model-path dup exists? [
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
-accessors combinators locals classes.tuple math.order ;
+accessors combinators locals classes.tuple math.order
+memoize ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
-: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
-: years ( n -- dt ) instant swap >>year ;
-: months ( n -- dt ) instant swap >>month ;
-: days ( n -- dt ) instant swap >>day ;
+MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
+: years ( n -- dt ) instant clone swap >>year ;
+: months ( n -- dt ) instant clone swap >>month ;
+: days ( n -- dt ) instant clone swap >>day ;
: weeks ( n -- dt ) 7 * days ;
-: hours ( n -- dt ) instant swap >>hour ;
-: minutes ( n -- dt ) instant swap >>minute ;
-: seconds ( n -- dt ) instant swap >>second ;
+: hours ( n -- dt ) instant clone swap >>hour ;
+: minutes ( n -- dt ) instant clone swap >>minute ;
+: seconds ( n -- dt ) instant clone swap >>second ;
: milliseconds ( n -- dt ) 1000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
M: duration time-
before time+ ;
-: <zero> 0 0 0 0 0 0 instant <timestamp> ;
+MEMO: <zero> ( -- timestamp )
+0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
-: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 instant <timestamp> ; foldable
+MEMO: unix-1970 ( -- timestamp )
+ 1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;
calendar calendar.format.macros ;\r
IN: calendar.format\r
\r
-: pad-00 number>string 2 CHAR: 0 pad-left ;\r
+: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
\r
-: pad-0000 number>string 4 CHAR: 0 pad-left ;\r
+: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
\r
-: pad-00000 number>string 5 CHAR: 0 pad-left ;\r
+: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
\r
-: write-00 pad-00 write ;\r
+: write-00 ( n -- ) pad-00 write ;\r
\r
-: write-0000 pad-0000 write ;\r
+: write-0000 ( n -- ) pad-0000 write ;\r
\r
-: write-00000 pad-00000 write ;\r
+: write-00000 ( n -- ) pad-00000 write ;\r
\r
-: hh hour>> write-00 ;\r
+: hh ( time -- ) hour>> write-00 ;\r
\r
-: mm minute>> write-00 ;\r
+: mm ( time -- ) minute>> write-00 ;\r
\r
-: ss second>> >integer write-00 ;\r
+: ss ( time -- ) second>> >integer write-00 ;\r
\r
-: D day>> number>string write ;\r
+: D ( time -- ) day>> number>string write ;\r
\r
-: DD day>> write-00 ;\r
+: DD ( time -- ) day>> write-00 ;\r
\r
-: DAY day-of-week day-abbreviations3 nth write ;\r
+: DAY ( time -- ) day-of-week day-abbreviations3 nth write ;\r
\r
-: MM month>> write-00 ;\r
+: MM ( time -- ) month>> write-00 ;\r
\r
-: MONTH month>> month-abbreviations nth write ;\r
+: MONTH ( time -- ) month>> month-abbreviations nth write ;\r
\r
-: YYYY year>> write-0000 ;\r
+: YYYY ( time -- ) year>> write-0000 ;\r
\r
-: YYYYY year>> write-00000 ;\r
+: YYYYY ( time -- ) year>> write-00000 ;\r
\r
: expect ( str -- )\r
read1 swap member? [ "Parse error" throw ] unless ;\r
\r
-: read-00 2 read string>number ;\r
+: read-00 ( -- n ) 2 read string>number ;\r
\r
-: read-000 3 read string>number ;\r
+: read-000 ( -- n ) 3 read string>number ;\r
\r
-: read-0000 4 read string>number ;\r
+: read-0000 ( -- n ) 4 read string>number ;\r
\r
GENERIC: day. ( obj -- )\r
\r
: timestamp>ymd ( timestamp -- str )\r
[ (timestamp>ymd) ] with-string-writer ;\r
\r
-: (timestamp>hms)\r
+: (timestamp>hms) ( timestamp -- )\r
{ hh ":" mm ":" ss } formatted ;\r
\r
: timestamp>hms ( timestamp -- str )\r
[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with
-: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ;
+: compiled-test-1 ( -- n )
+ { [ 1 throw ] [ 2 ] } attempt-all-quots ;
\ compiled-test-1 must-infer
! See http://www.faqs.org/rfcs/rfc1321.html
USING: kernel io io.binary io.files io.streams.byte-array math
-math.functions math.parser namespaces splitting strings
+math.functions math.parser namespaces splitting grouping strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib checksums ;
IN: checksums.md5
: S43 15 ; inline
: S44 21 ; inline
-: (process-md5-block-F)
+: (process-md5-block-F) ( block -- block )
dup S11 1 0 [ F ] ABCD
dup S12 2 1 [ F ] DABC
dup S13 3 2 [ F ] CDAB
dup S13 15 14 [ F ] CDAB
dup S14 16 15 [ F ] BCDA ;
-: (process-md5-block-G)
+: (process-md5-block-G) ( block -- block )
dup S21 17 1 [ G ] ABCD
dup S22 18 6 [ G ] DABC
dup S23 19 11 [ G ] CDAB
dup S23 31 7 [ G ] CDAB
dup S24 32 12 [ G ] BCDA ;
-: (process-md5-block-H)
+: (process-md5-block-H) ( block -- block )
dup S31 33 5 [ H ] ABCD
dup S32 34 8 [ H ] DABC
dup S33 35 11 [ H ] CDAB
dup S33 47 15 [ H ] CDAB
dup S34 48 2 [ H ] BCDA ;
-: (process-md5-block-I)
+: (process-md5-block-I) ( block -- block )
dup S41 49 0 [ I ] ABCD
dup S42 50 7 [ I ] DABC
dup S43 51 14 [ I ] CDAB
-USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols math.bitfields.lib checksums ;
+USING: crypto.common kernel splitting grouping
+math sequences namespaces io.binary symbols
+math.bitfields.lib checksums ;
IN: checksums.sha2
<PRIVATE
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii ;
+memoize debugger io.encodings.ascii effects ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: define-objc-class-word ( name quot -- )
[
over , , \ unless-defined , dup , \ objc-class ,
- ] [ ] make >r "cocoa.classes" create r> define ;
+ ] [ ] make >r "cocoa.classes" create r>
+ (( -- class )) define-declared ;
: import-objc-class ( name quot -- )
2dup unless-defined
\r
C: <linked-error> linked-error\r
\r
-: ?linked dup linked-error? [ rethrow ] when ;\r
+: ?linked ( message -- message )\r
+ dup linked-error? [ rethrow ] when ;\r
\r
TUPLE: linked-thread < thread supervisor ;\r
\r
M: thread send ( message thread -- )\r
check-registered mailbox-of mailbox-put ;\r
\r
-: my-mailbox self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ;\r
\r
: receive ( -- message )\r
my-mailbox mailbox-get ?linked ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: cords.tests
+USING: cords strings tools.test kernel sequences ;
+
+[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
+[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
--- /dev/null
+! Copysecond (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences sorting math math.order
+arrays combinators kernel ;
+IN: cords
+
+<PRIVATE
+
+TUPLE: simple-cord first second ;
+
+M: simple-cord length
+ [ first>> length ] [ second>> length ] bi + ;
+
+M: simple-cord virtual-seq first>> ;
+
+M: simple-cord virtual@
+ 2dup first>> length <
+ [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ;
+
+TUPLE: multi-cord count seqs ;
+
+M: multi-cord length count>> ;
+
+M: multi-cord virtual@
+ dupd
+ seqs>> [ first <=> ] binsearch*
+ [ first - ] [ second ] bi ;
+
+M: multi-cord virtual-seq
+ seqs>> dup empty? [ drop f ] [ first second ] if ;
+
+: <cord> ( seqs -- cord )
+ dup length 2 = [
+ first2 simple-cord boa
+ ] [
+ [ 0 [ length + ] accumulate ] keep zip multi-cord boa
+ ] if ;
+
+PRIVATE>
+
+UNION: cord simple-cord multi-cord ;
+
+INSTANCE: cord virtual-sequence
+
+INSTANCE: multi-cord virtual-sequence
+
+: cord-append ( seq1 seq2 -- cord )
+ {
+ { [ over empty? ] [ nip ] }
+ { [ dup empty? ] [ drop ] }
+ { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append <cord> ] }
+ { [ over cord? ] [ [ seqs>> values ] dip suffix <cord> ] }
+ { [ dup cord? ] [ seqs>> values swap prefix <cord> ] }
+ [ 2array <cord> ]
+ } cond ;
+
+: cord-concat ( seqs -- cord )
+ {
+ { [ dup empty? ] [ drop f ] }
+ { [ dup length 1 = ] [ first ] }
+ [
+ [
+ {
+ { [ dup cord? ] [ seqs>> values ] }
+ { [ dup empty? ] [ drop { } ] }
+ [ 1array ]
+ } cond
+ ] map concat <cord>
+ ]
+ } cond ;
--- /dev/null
+Virtual sequence concatenation
--- /dev/null
+collections
SYMBOL: event-stream-callbacks
-: event-stream-counter \ event-stream-counter counter ;
+: event-stream-counter ( -- n )
+ \ event-stream-counter counter ;
[
event-stream-callbacks global
!
USING: kernel math sequences words arrays io io.files namespaces
math.parser assocs quotations parser parser-combinators
-tools.time io.encodings.binary ;
+tools.time io.encodings.binary sequences.deep symbols combinators ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
{ "M" { flag-m? } }
} at ;
-SYMBOL: $1
-SYMBOL: $2
-SYMBOL: $3
-SYMBOL: $4
+SYMBOLS: $1 $2 $3 $4 ;
: replace-patterns ( vector tree -- tree )
- #! Copy the tree, replacing each occurence of
- #! $1, $2, etc with the relevant item from the
- #! given index.
- dup quotation? over [ ] = not and [ ! vector tree
- dup first swap rest ! vector car cdr
- >r dupd replace-patterns ! vector v R: cdr
- swap r> replace-patterns >r 1quotation r> append
- ] [ ! vector value
- dup $1 = [ drop 0 over nth ] when
- dup $2 = [ drop 1 over nth ] when
- dup $3 = [ drop 2 over nth ] when
- dup $4 = [ drop 3 over nth ] when
- nip
- ] if ;
-
-: test-rp
- { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
+ [
+ {
+ { $1 [ first ] }
+ { $2 [ second ] }
+ { $3 [ third ] }
+ { $4 [ fourth ] }
+ [ nip ]
+ } case
+ ] with deep-map ;
: (emulate-RST) ( n cpu -- )
#! RST nn
"H" token <|>
"L" token <|> [ register-lookup ] <@ ;
-: all-flags
+: all-flags ( -- parser )
#! A parser for 16-bit flags.
"NZ" token
"NC" token <|>
"P" token <|>
"M" token <|> [ flag-lookup ] <@ ;
-: 16-bit-registers
+: 16-bit-registers ( -- parser )
#! A parser for 16-bit registers. On a successfull parse the
#! parse tree contains a vector. The first item in the vector
#! is the getter word for that register with stack effect
16-bit-registers indirect <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-RR,NN-instruction
+: LD-RR,NN-instruction ( -- parser )
#! LD BC,nn
"LD-RR,NN" "LD" complex-instruction
16-bit-registers sp <&>
",nn" token <&
just [ first2 swap curry ] <@ ;
-: LD-R,N-instruction
+: LD-R,N-instruction ( -- parser )
#! LD B,n
"LD-R,N" "LD" complex-instruction
8-bit-registers sp <&>
",n" token <&
just [ first2 swap curry ] <@ ;
-: LD-(RR),N-instruction
+: LD-(RR),N-instruction ( -- parser )
"LD-(RR),N" "LD" complex-instruction
16-bit-registers indirect sp <&>
",n" token <&
just [ first2 swap curry ] <@ ;
-: LD-(RR),R-instruction
+: LD-(RR),R-instruction ( -- parser )
#! LD (BC),A
"LD-(RR),R" "LD" complex-instruction
16-bit-registers indirect sp <&>
8-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-R,R-instruction
+: LD-R,R-instruction ( -- parser )
"LD-R,R" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-RR,RR-instruction
+: LD-RR,RR-instruction ( -- parser )
"LD-RR,RR" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-R,(RR)-instruction
+: LD-R,(RR)-instruction ( -- parser )
"LD-R,(RR)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-(NN),RR-instruction
+: LD-(NN),RR-instruction ( -- parser )
"LD-(NN),RR" "LD" complex-instruction
"nn" token indirect sp <&
"," token <&
16-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: LD-(NN),R-instruction
+: LD-(NN),R-instruction ( -- parser )
"LD-(NN),R" "LD" complex-instruction
"nn" token indirect sp <&
"," token <&
8-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: LD-RR,(NN)-instruction
+: LD-RR,(NN)-instruction ( -- parser )
"LD-RR,(NN)" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
"nn" token indirect <&
just [ first2 swap curry ] <@ ;
-: LD-R,(NN)-instruction
+: LD-R,(NN)-instruction ( -- parser )
"LD-R,(NN)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
"nn" token indirect <&
just [ first2 swap curry ] <@ ;
-: OUT-(N),R-instruction
+: OUT-(N),R-instruction ( -- parser )
"OUT-(N),R" "OUT" complex-instruction
"n" token indirect sp <&
"," token <&
8-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: IN-R,(N)-instruction
+: IN-R,(N)-instruction ( -- parser )
"IN-R,(N)" "IN" complex-instruction
8-bit-registers sp <&>
"," token <&
"n" token indirect <&
just [ first2 swap curry ] <@ ;
-: EX-(RR),RR-instruction
+: EX-(RR),RR-instruction ( -- parser )
"EX-(RR),RR" "EX" complex-instruction
16-bit-registers indirect sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: EX-RR,RR-instruction
+: EX-RR,RR-instruction ( -- parser )
"EX-RR,RR" "EX" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: 8080-generator-parser
+: 8080-generator-parser ( -- parser )
NOP-instruction
RST-0-instruction <|>
RST-8-instruction <|>
#! that would implement that instruction.
dup " " join instruction-quotations
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
- r> define ;
+ r> (( cpu -- )) define-declared ;
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
-USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints math.bitfields.lib
-assocs ;
+USING: arrays kernel io io.binary sbufs splitting grouping
+strings sequences namespaces math math.parser parser
+hints math.bitfields.lib assocs ;
IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline
FUNCTION: void PQfreemem ( void* ptr ) ;
! Exists for backward compatibility.
-: PQfreeNotify PQfreemem ;
+: PQfreeNotify ( ptr -- ) PQfreemem ;
!
! Make an empty PGresult with given status (some apps find this
: param-types ( statement -- seq )
in-params>> [ type>> type>oid ] map >c-uint-array ;
-: malloc-byte-array/length
+: malloc-byte-array/length ( byte-array -- alien length )
[ malloc-byte-array &free ] [ length ] bi ;
-: default-param-value
+: default-param-value ( obj -- alien n )
number>string* dup [ utf8 malloc-string &free ] when 0 ;
: param-values ( statement -- seq seq2 )
where group-by having order-by limit offset is-null desc all
any count avg table values ;
-: input-spec, 1, ;
-: output-spec, 2, ;
-: input, 3, ;
-: output, 4, ;
+: input-spec, ( obj -- ) 1, ;
+: output-spec, ( obj -- ) 2, ;
+: input, ( obj -- ) 3, ;
+: output, ( obj -- ) 4, ;
DEFER: sql%
PROTOCOL: assoc-protocol
at* assoc-size >alist set-at assoc-clone-like
- { assoc-find 1 } delete-at clear-assoc new-assoc
- assoc-like ;
+ delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel math models namespaces sequences strings
-splitting combinators unicode.categories math.order ;
+USING: accessors arrays io kernel math models namespaces
+sequences strings splitting combinators unicode.categories
+math.order ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
V{ "" } clone <model> V{ } clone
{ set-delegate set-document-locs } document construct ;
-: add-loc document-locs push ;
+: add-loc ( loc document -- ) locs>> push ;
-: remove-loc document-locs delete ;
+: remove-loc ( loc document -- ) locs>> delete ;
: update-locs ( loc document -- )
document-locs [ set-model ] with each ;
>r >r first2 swap r> doc-line r> call
r> =col ; inline
-: ((word-elt)) [ ?nth blank? ] 2keep ;
+: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
[ >r blank? r> xor ] curry ; inline
[ file>> path>> ] [ line>> ] bi edit-location
] when* ;
-: fix ( word -- )
- [ "Fixing " write pprint " and all usages..." print nl ]
- [ [ smart-usage ] keep prefix ] bi
+: edit-each ( seq -- )
[
[ "Editing " write . ]
[
readln
] bi
] all? drop ;
+
+: fix ( word -- )
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ smart-usage ] keep prefix ] bi
+ edit-each ;
QUALIFIED: namespaces
IN: fry
-: , "Only valid inside a fry" throw ;
-: @ "Only valid inside a fry" throw ;
-: _ "Only valid inside a fry" throw ;
+: , ( -- * ) "Only valid inside a fry" throw ;
+: @ ( -- * ) "Only valid inside a fry" throw ;
+: _ ( -- * ) "Only valid inside a fry" throw ;
DEFER: (shallow-fry)
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table user ensure-table ;
+: init-users-table ( -- ) user ensure-table ;
SINGLETON: users-in-db
TUPLE: boilerplate < filter-responder template ;
-: <boilerplate> f boilerplate boa ;
+: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
SYMBOL: exit-continuation
-: exit-with exit-continuation get continue-with ;
+: exit-with ( value -- )
+ exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: get-session ( id -- session )
dup [ <session> select-tuple ] when ;
-: init-sessions-table session ensure-table ;
+: init-sessions-table ( -- ) session ensure-table ;
: start-expiring-sessions ( db seq -- )
'[
csv accessors assocs strings math splitting ;
IN: geo-ip
-: db-path "IpToCountry.csv" temp-file ;
+: db-path ( -- path ) "IpToCountry.csv" temp-file ;
-: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
+: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
: download-db ( -- path )
db-path dup exists? [
<PRIVATE
-: 'char' [ ",*?" member? not ] satisfy ;
+: 'char' ( -- parser )
+ [ ",*?" member? not ] satisfy ;
-: 'string' 'char' <+> [ >lower token ] <@ ;
+: 'string' ( -- parser )
+ 'char' <+> [ >lower token ] <@ ;
-: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
+: 'escaped-char' ( -- parser )
+ "\\" token any-char-parser &> [ 1token ] <@ ;
-: 'escaped-string' 'string' 'escaped-char' <|> ;
+: 'escaped-string' ( -- parser )
+ 'string' 'escaped-char' <|> ;
DEFER: 'term'
'glob' "," token nonempty-list-of "{" "}" surrounded-by
[ <or-parser> ] <@ ;
-LAZY: 'term'
+LAZY: 'term' ( -- parser )
'union'
'character-class' <|>
"?" token [ drop any-char-parser ] <@ <|>
PRIVATE>
-: <glob> 'glob' just parse-1 just ;
+: <glob> ( string -- glob ) 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? )
[ >lower ] [ <glob> ] bi* parse nil? not ;
M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
-: pull-win32-string [ utf16n alien>string ] keep free ;
+: pull-win32-string ( alien -- string )
+ [ utf16n alien>string ] keep free ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
USE: io
IN: hello-world
-: hello "Hello world" print ;
+: hello ( -- ) "Hello world" print ;
MAIN: hello
$nl
"Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece."
$nl
-"Most words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } ". See " { $link "effect-declaration" } "."
+"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "."
$nl
"Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:"
{ $table
"The " { $link dup } " word makes a copy of the value at the top of the stack:"
{ $example "5 dup * ." "25" }
"The " { $link sq } " word is actually defined as follows:"
-{ $code ": sq dup * ;" }
+{ $code ": sq ( x -- y ) dup * ;" }
"(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)"
$nl
"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
"This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":"
{ $code
": a 1 ;"
- ": b a 1 + ;"
+ ": b ( -- x ) a 1 + ;"
": a 2 ;"
"b ."
}
"In Factor, this example will print 3 since word redefinition is explicitly supported."
+ $nl
+ "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "."
}
{ $references
{ "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." }
M: word article-name word-name ;
M: word article-title
- dup parsing? over symbol? or [
+ dup [ parsing-word? ] [ symbol? ] bi or [
word-name
] [
- dup word-name
- swap stack-effect
- [ effect>string " " swap 3append ] when*
+ [ word-name ]
+ [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
+ append
] if ;
M: word article-content
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
-: (:help-multi)
- "This error has multiple delegates:" print
- ($index) nl
- "Use \\ ... help to get help about a specific delegate." print ;
-
-: (:help-none)
- drop "No help for this error. " print ;
-
-: (:help-debugger)
+: :help-debugger ( -- )
nl
"Debugger commands:" print
nl
":vars - list all variables at error time" print ;
: :help ( -- )
- error get delegates [ error-help ] map sift
- {
- { [ dup empty? ] [ (:help-none) ] }
- { [ dup length 1 = ] [ first help ] }
- [ (:help-multi) ]
- } cond (:help-debugger) ;
+ error get error-help [ help ] [ "No help for this error. " print ] if*
+ :help-debugger ;
: remove-article ( name -- )
dup articles get key? [
SYMBOL: block
SYMBOL: table
-: last-span? last-element get span eq? ;
-: last-block? last-element get block eq? ;
+: last-span? ( -- ? ) last-element get span eq? ;
+: last-block? ( -- ? ) last-element get block eq? ;
: ($span) ( quot -- )
last-block? [ nl ] when
! Some spans
-: $snippet [ snippet-style get print-element* ] ($span) ;
+: $snippet ( children -- )
+ [ snippet-style get print-element* ] ($span) ;
-: $emphasis [ emphasis-style get print-element* ] ($span) ;
+: $emphasis ( children -- )
+ [ emphasis-style get print-element* ] ($span) ;
-: $strong [ strong-style get print-element* ] ($span) ;
+: $strong ( children -- )
+ [ strong-style get print-element* ] ($span) ;
-: $url [ url-style get print-element* ] ($span) ;
+: $url ( children -- )
+ [ url-style get print-element* ] ($span) ;
-: $nl nl nl drop ;
+: $nl ( children -- )
+ nl nl drop ;
! Some blocks
-: ($heading)
+: ($heading) ( children quot -- )
last-element get [ nl ] when ($block) ; inline
: $heading ( element -- )
M: string ($instance)
dup a/an write bl $snippet ;
-: $instance first ($instance) ;
+: $instance ( children -- ) first ($instance) ;
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
drop
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
-: $low-level-note
+: $low-level-note ( children -- )
drop
"Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
-: $values-x/y
+: $values-x/y ( children -- )
drop { { "x" number } { "y" number } } $values ;
-: $io-error
+: $io-error ( children -- )
drop
"Throws an error if the I/O operation fails." $errors ;
-: $prettyprinting-note
+: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
{ $link with-pprint } " combinator."
: ABOUT:
scan-object
in get vocab
- dup changed-definition
+ dup +inlined+ changed-definition
set-vocab-help ; parsing
USING: arrays io io.streams.string kernel math math.parser namespaces
- prettyprint sequences sequences.lib splitting strings ascii ;
+prettyprint sequences sequences.lib splitting grouping strings ascii ;
IN: hexdump
<PRIVATE
SYMBOL: values
-: value values get at ;
+: value ( name -- value ) values get at ;
-: set-value values get set-at ;
+: set-value ( value name -- ) values get set-at ;
-: blank-values H{ } clone values set ;
+: blank-values ( -- ) H{ } clone values set ;
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
#! dynamically creating words.
>r >r elements-vocab create r> r> define-declared ;
-: <foo> "<" swap ">" 3append ;
-
-: empty-effect T{ effect f 0 0 } ;
+: <foo> ( str -- <str> ) "<" swap ">" 3append ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap [ <foo> write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
-: <foo "<" prepend ;
+: <foo ( str -- <str ) "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
<foo dup [ write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
-: foo> ">" append ;
+: foo> ( str -- foo> ) ">" append ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
- foo> [ ">" write-html ] empty-effect html-word ;
+ foo> [ ">" write-html ] (( -- )) html-word ;
-: </foo> "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup [ write-html ] curry empty-effect html-word ;
+ </foo> dup [ write-html ] curry (( -- )) html-word ;
-: <foo/> "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap [ <foo/> write-html ] curry
- empty-effect html-word ;
+ (( -- )) html-word ;
-: foo/> "/>" append ;
+: foo/> ( str -- str/> ) "/>" append ;
: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
#! word.
- foo/> [ "/>" write-html ] empty-effect html-word ;
+ foo/> [ "/>" write-html ] (( -- )) html-word ;
: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
present escape-quoted-string write-html
"'" write-html ;
-: attribute-effect T{ effect f { "string" } 0 } ;
-
: define-attribute-word ( name -- )
dup "=" prepend swap
- [ write-attr ] curry attribute-effect html-word ;
+ [ write-attr ] curry (( string -- )) html-word ;
! Define some closed HTML tags
[
M: html-block-stream dispose ( quot style stream -- )
end-sub-stream a-div format-html-div ;
-: border-spacing-css,
+: border-spacing-css, ( pair -- )
"padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str )
IN: http
-: crlf "\r\n" write ;
+: crlf ( -- ) "\r\n" write ;
: add-header ( value key assoc -- )
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
-: <request>
+: <request> ( -- request )
request new
"1.1" >>version
<url>
content-charset
body ;
-: <response>
+: <response> ( -- response )
response new
"1.1" >>version
H{ } clone >>header
now timestamp>http-string "date" set-header
V{ } clone >>cookies ;
-: read-response-version
+: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
-: read-response-code
+: read-response-code ( response -- response )
" \t" read-until [ "Bad response: code" throw ] unless
string>number [ "Bad response: code" throw ] unless*
>>code ;
-: read-response-message
+: read-response-message ( response -- response )
read-crlf >>message ;
-: read-response-header
+: read-response-header ( response -- response )
read-header >>header
dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [
http accessors sequences strings math.parser fry urls ;\r
IN: http.server.cgi\r
\r
-: post? request get method>> "POST" = ;\r
+: post? ( -- ? ) request get method>> "POST" = ;\r
\r
: cgi-variables ( script-path -- assoc )\r
#! This needs some work.\r
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io
-io.files splitting io.binary math.functions vectors quotations
-combinators io.encodings.binary ;
+io.files splitting grouping io.binary math.functions vectors
+quotations combinators io.encodings.binary ;
IN: icfp.2006
SYMBOL: regs
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit boa ] 2curry dupd curry define ;
+ [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ;
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
-io splitting sequences sequences.lib namespaces kernel
+io splitting grouping sequences sequences.lib namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes
<PRIVATE
-: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
-: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
+: ?reader ( handle/f -- stream )
+ [ <input-port> &dispose ] [ input-stream get ] if* ;
+
+: ?writer ( handle/f -- stream )
+ [ <output-port> &dispose ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
-dlists assocs io.encodings.binary inspector accessors
+grouping dlists assocs io.encodings.binary inspector accessors
destructors ;
IN: io.ports
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
-alien.c-types math.parser splitting math assocs inspector ;
+alien.c-types math.parser splitting grouping
+math assocs inspector ;
IN: io.sockets
<< {
SYMBOL: port-override
-: (port) port-override get swap or ;
+: (port) ( port -- port' ) port-override get swap or ;
PRIVATE>
[ >r >r underlying-handle r> r> redirect ]
} cond ;
-: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
+: ?closed ( obj -- obj' )
+ dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( process -- process )
dup stdin>> ?closed read-flags 0 redirect
: init-fdset ( fds fdset -- )
[ >r t swap munge r> set-nth ] curry each ;
-: read-fdset/tasks
+: read-fdset/tasks ( mx -- seq fdset )
[ reads>> keys ] [ read-fdset>> ] bi ;
-: write-fdset/tasks
+: write-fdset/tasks ( mx -- seq fdset )
[ writes>> keys ] [ write-fdset>> ] bi ;
: max-fd ( assoc -- n )
IN: koszul
! Utilities
-: -1^ odd? -1 1 ? ;
+: -1^ ( m -- n ) odd? -1 1 ? ;
: >alt ( obj -- vec )
{
[ 1array >alt ]
} cond ;
-: canonicalize
+: canonicalize ( assoc -- assoc' )
[ nip zero? not ] assoc-filter ;
SYMBOL: terms
[ v- ] 2map ;
! Laplacian
-: m.m' dup flip m. ;
-: m'.m dup flip swap m. ;
+: m.m' ( matrix -- matrix' ) dup flip m. ;
+: m'.m ( matrix -- matrix' ) dup flip swap m. ;
: empty-matrix? ( matrix -- ? )
dup empty? [ drop t ] [ first empty? ] if ;
USING: lists.lazy math kernel sequences quotations ;
IN: lists.lazy.examples
-: naturals 0 lfrom ;
-: positives 1 lfrom ;
-: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 1 [ 2 * ] lfrom-by ;
-: ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lazy-map ;
-: first-five-squares 5 squares ltake list>array ;
+: naturals ( -- list ) 0 lfrom ;
+: positives ( -- list ) 1 lfrom ;
+: evens ( -- list ) 0 [ 2 + ] lfrom-by ;
+: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ;
+: ones ( -- list ) 1 [ ] lfrom-by ;
+: squares ( -- list ) naturals [ dup * ] lazy-map ;
+: first-five-squares ( -- list ) 5 squares ltake list>array ;
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
-: get-local-test-1 3 >r 1 get-local r> drop ;
+: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
-{ 0 1 } [ get-local-test-1 ] must-infer-as
+\ get-local-test-1 must-infer
[ 3 ] [ get-local-test-1 ] unit-test
-: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
-{ 0 1 } [ get-local-test-2 ] must-infer-as
+\ get-local-test-2 must-infer
[ 4 ] [ get-local-test-2 ] unit-test
-: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
-{ 0 2 } [ get-local-test-3 ] must-infer-as
+\ get-local-test-3 must-infer
[ 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 ;
+: get-local-test-4 ( -- a b )
+ 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
-{ 0 2 } [ get-local-test-4 ] must-infer-as
+\ get-local-test-4 must-infer
[ 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> ;
+: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
-{ 0 2 } [ load-locals-test-1 ] must-infer-as
+\ load-locals-test-1 must-infer
[ 1 2 ] [ load-locals-test-1 ] unit-test
GENERIC: local-rewrite* ( obj -- )
-: lambda-rewrite
+: lambda-rewrite ( quot -- quot' )
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
let-rewrite ;
: parse-locals ( -- vars assoc )
- parse-effect
+ ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals dup push-locals ;
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
-: (M::)
+: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences namespaces words assocs logging sorting\r
-prettyprint io io.styles strings logging.parser calendar.format ;\r
+prettyprint io io.styles strings logging.parser calendar.format\r
+combinators ;\r
IN: logging.analysis\r
\r
SYMBOL: word-names\r
] curry assoc-each\r
] tabular-output ;\r
\r
-: log-entry.\r
+: log-entry. ( entry -- )\r
"====== " write\r
- dup first (timestamp>string) bl\r
- dup second pprint bl\r
- dup third write nl\r
- fourth "\n" join print ;\r
+ {\r
+ [ first (timestamp>string) bl ]\r
+ [ second pprint bl ]\r
+ [ third write nl ]\r
+ [ fourth "\n" join print ]\r
+ } cleave ;\r
\r
: errors. ( errors -- )\r
[ log-entry. ] each ;\r
\r
<PRIVATE\r
\r
-: one-string?\r
+: one-string? ( obj -- ? )\r
{\r
[ dup array? ]\r
[ dup length 1 = ]\r
3drop\r
] if ; inline\r
\r
-: input# stack-effect in>> length ;\r
+: input# ( word -- n ) stack-effect in>> length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
\r
-: output# stack-effect out>> length ;\r
+: output# ( word -- n ) stack-effect out>> length ;\r
\r
: output-logging-quot ( quot word level -- quot' )\r
[ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
#! Syntax: name level\r
CREATE-WORD dup scan-word\r
'[ 1array stack>message , , log-message ]\r
- define ; parsing\r
+ (( message -- )) define-declared ; parsing\r
calendar calendar.format ;\r
IN: logging.parser\r
\r
-: string-of satisfy <!*> [ >string ] <@ ;\r
+: string-of ( quot -- parser ) satisfy <!*> [ >string ] <@ ;\r
\r
SYMBOL: multiline\r
\r
-: 'date'\r
+: 'date' ( -- parser )\r
[ "]" member? not ] string-of [\r
dup multiline-header =\r
[ drop multiline ] [ rfc3339>timestamp ] if\r
] <@\r
"[" "]" surrounded-by ;\r
\r
-: 'log-level'\r
+: 'log-level' ( -- parser )\r
log-levels [\r
[ word-name token ] keep [ nip ] curry <@\r
] map <or-parser> ;\r
\r
-: 'word-name'\r
+: 'word-name' ( -- parser )\r
[ " :" member? not ] string-of ;\r
\r
SYMBOL: malformed\r
\r
-: 'malformed-line'\r
+: 'malformed-line' ( -- parser )\r
[ drop t ] string-of [ malformed swap 2array ] <@ ;\r
\r
-: 'log-message'\r
+: 'log-message' ( -- parser )\r
[ drop t ] string-of [ 1vector ] <@ ;\r
\r
MEMO: 'log-line' ( -- parser )\r
: multiline? ( line -- ? )\r
first multiline eq? ;\r
\r
-: malformed-line\r
+: malformed-line ( line -- )\r
"Warning: malformed log line:" print\r
second print ;\r
\r
: ?delete-file ( path -- )\r
dup exists? [ delete-file ] [ drop ] if ;\r
\r
-: delete-oldest keep-logs log# ?delete-file ;\r
+: delete-oldest ( service -- ) keep-logs log# ?delete-file ;\r
\r
: ?move-file ( old new -- )\r
over exists? [ move-file ] [ 2drop ] if ;\r
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
-: saver \ >r <repetition> >quotation ;
+: saver ( n -- quot ) \ >r <repetition> >quotation ;
-: restorer \ r> <repetition> >quotation ;
+: restorer ( n -- quot ) \ r> <repetition> >quotation ;
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences classes.tuple
-combinators macros assocs math ;
+combinators macros assocs math effects ;
IN: match
SYMBOL: _
: define-match-var ( name -- )
create-in
dup t "match-var" set-word-prop
- dup [ get ] curry define ;
+ dup [ get ] curry (( -- value )) define-declared ;
: define-match-vars ( seq -- )
[ define-match-var ] each ;
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting columns ;
+math.functions kernel splitting grouping columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;
gcd nip
] unit-test
-: verify-gcd
+: verify-gcd ( a b -- ? )
2dup gcd
>r rot * swap rem r> = ;
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting columns ;
+USING: sequences math kernel splitting grouping columns ;
IN: math.haar
: averages ( seq -- seq )
: echelon ( matrix -- matrix' )
[ 0 0 (echelon) ] with-matrix ;
-: nonzero-rows [ [ zero? ] all? not ] filter ;
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? not ] filter ;
: null/rank ( matrix -- null rank )
echelon dup length swap nonzero-rows length [ - ] keep ;
<PRIVATE
-: x first ; inline
-: y second ; inline
-: z third ; inline
+: x ( seq -- elt ) first ; inline
+: y ( seq -- elt ) second ; inline
+: z ( seq -- elt ) third ; inline
-: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
+: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
+: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
+: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
PRIVATE>
#! divide the last two numbers in the sequences
[ peek ] bi@ / ;
-: (p/mod)
+: (p/mod) ( p p -- p p )
2dup /-last
2dup , n*p swapd
p- >vector
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting sequences.lib ;
+ sequences splitting grouping sequences.lib ;
IN: math.text.english
<PRIVATE
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
-: invalidate-memoized ! ( inputs... word )
+: invalidate-memoized ( inputs... word -- )
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
{ $slide "Questions?" }
} ;
-: minneapolis-talk minneapolis-slides slides-window ;
+: minneapolis-talk ( -- ) minneapolis-slides slides-window ;
MAIN: minneapolis-talk
: <history> ( value -- history )
history construct-model dup reset-history ;
-: (add-history)
+: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
MIXIN: monad
GENERIC: monad-of ( mvalue -- singleton )
-GENERIC: return ( string singleton -- mvalue )
+GENERIC: return ( value singleton -- mvalue )
GENERIC: fail ( value singleton -- mvalue )
GENERIC: >>= ( mvalue -- quot )
SINGLETON: nothing
TUPLE: just value ;
-: just \ just boa ;
+: just ( value -- just ) \ just boa ;
UNION: maybe just nothing ;
INSTANCE: maybe monad
INSTANCE: either-monad monad
TUPLE: left value ;
-: left \ left boa ;
+: left ( value -- left ) \ left boa ;
TUPLE: right value ;
-: right \ right boa ;
+: right ( value -- right ) \ right boa ;
UNION: either left right ;
INSTANCE: either monad
INSTANCE: state-monad monad
TUPLE: state quot ;
-: state \ state boa ;
+: state ( quot -- state ) \ state boa ;
INSTANCE: state monad
M: state-monad return drop '[ , 2array ] state ;
M: state-monad fail "Fail" throw ;
-: mcall quot>> call ;
+: mcall ( state -- ) quot>> call ;
M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
: run-st ( state initial -- ) swap mcall second ;
-: return-st state-monad return ;
+: return-st ( value -- mvalue ) state-monad return ;
! Reader
SINGLETON: reader-monad
INSTANCE: reader-monad monad
TUPLE: reader quot ;
-: reader \ reader boa ;
+: reader ( quot -- reader ) \ reader boa ;
INSTANCE: reader monad
M: reader monad-of drop reader-monad ;
INSTANCE: writer-monad monad
TUPLE: writer value log ;
-: writer \ writer boa ;
+: writer ( value log -- writer ) \ writer boa ;
M: writer monad-of drop writer-monad ;
USING: io kernel math math.functions math.parser parser
-namespaces sequences splitting combinators continuations
-sequences.lib ;
+namespaces sequences splitting grouping combinators
+continuations sequences.lib ;
IN: money
: dollars/cents ( dollars -- dollars cents )
USING: kernel io parser words namespaces quotations arrays assocs sequences
- splitting math shuffle ;
+ splitting grouping math shuffle ;
IN: mortar
drop [ <method> dup ] 2keep reveal-method
] if ;
-: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
: create-method-in ( specializer generic -- method )
create-method dup save-location f set-word ;
-: CREATE-METHOD
+: CREATE-METHOD ( -- method )
scan-word scan-object swap create-method-in ;
-: (METHOD:) CREATE-METHOD parse-definition ;
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
: METHOD: (METHOD:) define ; parsing
: get-building-seq ( n -- seq )
building-seq get nth ;
-: n, get-building-seq push ;
-: n% get-building-seq push-all ;
-: n# >r number>string r> n% ;
-
-: 0, 0 n, ;
-: 0% 0 n% ;
-: 0# 0 n# ;
-: 1, 1 n, ;
-: 1% 1 n% ;
-: 1# 1 n# ;
-: 2, 2 n, ;
-: 2% 2 n% ;
-: 2# 2 n# ;
-: 3, 3 n, ;
-: 3% 3 n% ;
-: 3# 3 n# ;
-: 4, 4 n, ;
-: 4% 4 n% ;
-: 4# 4 n# ;
+: n, ( obj n -- ) get-building-seq push ;
+: n% ( seq n -- ) get-building-seq push-all ;
+: n# ( num n -- ) >r number>string r> n% ;
+
+: 0, ( obj -- ) 0 n, ;
+: 0% ( seq -- ) 0 n% ;
+: 0# ( num -- ) 0 n# ;
+: 1, ( obj -- ) 1 n, ;
+: 1% ( seq -- ) 1 n% ;
+: 1# ( num -- ) 1 n# ;
+: 2, ( obj -- ) 2 n, ;
+: 2% ( seq -- ) 2 n% ;
+: 2# ( num -- ) 2 n# ;
+: 3, ( obj -- ) 3 n, ;
+: 3% ( seq -- ) 3 n% ;
+: 3# ( num -- ) 3 n# ;
+: 4, ( obj -- ) 4 n, ;
+: 4% ( seq -- ) 4 n% ;
+: 4# ( num -- ) 4 n# ;
MACRO:: nmake ( quot exemplars -- )
[let | n [ exemplars length ] |
nehe.2 nehe.3 nehe.4 nehe.5 kernel ;
IN: nehe
-: nehe-window
+: nehe-window ( -- )
[
[
"Nehe 2" [ drop run2 ] <bevel-button> gadget,
: read-number ( -- n ) readln string>number ;
-: guess-banner
+: guess-banner ( -- )
"I'm thinking of a number between 0 and 100." print ;
-: guess-prompt "Enter your guess: " write ;
-: too-high "Too high" print ;
-: too-low "Too low" print ;
-: correct "Correct - you win!" print ;
+: guess-prompt ( -- ) "Enter your guess: " write ;
+: too-high ( -- ) "Too high" print ;
+: too-low ( -- ) "Too low" print ;
+: correct ( -- ) "Correct - you win!" print ;
: inexact-guess ( actual guess -- )
< [ too-high ] [ too-low ] if ;
dup guess-prompt read-number judge-guess
[ numbers-game-loop ] [ drop ] if ;
-: numbers-game number-to-guess numbers-game-loop ;
+: numbers-game ( -- ) number-to-guess numbers-game-loop ;
MAIN: numbers-game
f init set-global
] unless ;
-: <uint-array> "ALuint" <c-array> ;
+: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
: gen-sources ( size -- seq )
dup <uint-array> 2dup alGenSources swap c-uint-array> ;
splitting words byte-arrays assocs combinators.lib ;
IN: opengl
-: coordinates [ first2 ] bi@ ;
+: coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 ] bi@ ;
-: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ;
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
-: (gl-poly) [ [ gl-vertex ] each ] do-state ;
+: (gl-poly) ( points state -- )
+ [ [ gl-vertex ] each ] do-state ;
: gl-fill-poly ( points -- )
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
: gl-poly ( points -- )
GL_LINE_LOOP (gl-poly) ;
-: circle-steps dup length v/n 2 pi * v*n ;
+: circle-steps ( steps -- angles )
+ dup length v/n 2 pi * v*n ;
-: unit-circle dup [ sin ] map swap [ cos ] map ;
+: unit-circle ( angles -- points1 points2 )
+ [ [ sin ] map ] [ [ cos ] map ] bi ;
-: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
+: adjust-points ( points1 points2 -- points1' points2' )
+ [ [ 1 + 0.5 * ] map ] bi@ ;
-: scale-points zip [ v* ] with map [ v+ ] with map ;
+: scale-points ( loc dim points1 points2 -- points )
+ zip [ v* ] with map [ v+ ] with map ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: <sprite> ( loc dim dim2 -- sprite )
f f sprite boa ;
-: sprite-size2 sprite-dim2 first2 ;
+: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
-: sprite-width sprite-dim first ;
+: sprite-width ( sprite -- w ) sprite-dim first ;
: gray-texture ( sprite pixmap -- id )
gen-texture [
TUPLE: bio handle disposed ;
-: <bio> f bio boa ;
+: <bio> ( handle -- bio ) f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
TUPLE: rsa handle disposed ;
-: <rsa> f rsa boa ;
+: <rsa> ( handle -- rsa ) f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
assocs sequences.private optimizer.specializers generic
-combinators sorting math quotations ;
+combinators sorting math quotations accessors ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
: effect-str ( node -- str )
[
- " " over node-in-d values%
- " r: " over node-in-r values%
+ " " over in-d>> values%
+ " r: " over in-r>> values%
" --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
+ " " over out-d>> values%
+ " r: " swap out-r>> values%
] "" make rest ;
MACRO: match-choose ( alist -- )
} match-choose ;
M: #shuffle node>quot
- dup node-in-d over node-out-d pretty-shuffle
+ dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
[ , ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " prepend comment, ;
-: pushed-literals node-out-d [ value-literal literalize ] map ;
+: pushed-literals ( node -- seq )
+ out-d>> [ value-literal literalize ] map ;
M: #push node>quot nip pushed-literals % ;
DEFER: dataflow>quot
: #call>quot ( ? node -- )
- dup node-param dup ,
+ dup param>> dup ,
[ dup effect-str ] [ "empty call" ] if comment, ;
M: #call node>quot #call>quot ;
M: #label node>quot
[
- dup node-param literalize ,
+ dup param>> literalize ,
dup #label-loop? "#loop: " "#label: " ?
- over node-param word-name append comment,
+ over param>> word-name append comment,
] 2keep
node-child swap dataflow>quot , \ call , ;
M: #if node>quot
[ "#if" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map %
+ children>> swap [ dataflow>quot ] curry map %
\ if , ;
M: #dispatch node>quot
[ "#dispatch" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map ,
+ children>> swap [ dataflow>quot ] curry map ,
\ dispatch , ;
-M: #>r node>quot nip
node-in-d length \ >r <array> % ;
+M: #>r node>quot nip
in-d>> length \ >r <array> % ;
-M: #r> node>quot nip
node-out-d length \ r> <array> % ;
+M: #r> node>quot nip
out-d>> length \ r> <array> % ;
M: object node>quot
[
dup class word-name %
" " %
- dup node-param unparse %
+ dup param>> unparse %
" " %
dup effect-str %
] "" make comment, ;
: (dataflow>quot) ( ? node -- )
dup [
- 2dup node>quot node-successor (dataflow>quot)
+ 2dup node>quot successor>> (dataflow>quot)
] [
2drop
] if ;
0 swap [
>r 1+ r>
dup #call? [
- node-param {
+ param>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
>r optimize-1\r
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
\r
-: results\r
+: results ( seq -- )\r
[ [ second ] prepose compare ] curry sort 20 tail*\r
print\r
standard-table-style\r
[ [ [ pprint-cell ] each ] with-row ] each\r
] tabular-output ;\r
\r
-: optimizer-report\r
+: optimizer-report ( -- )\r
all-words [ compiled? ] filter\r
[\r
dup [\r
USING: kernel namespaces
math math.constants math.functions math.matrices math.vectors
- sequences splitting self math.trig ;
+ sequences splitting grouping self math.trig ;
IN: ori
USING: math math.parser calendar calendar.format strings words
-kernel ;
+kernel effects ;
IN: present
GENERIC: present ( object -- string )
M: word present word-name ;
+M: effect present effect>string ;
+
M: f present drop "" ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces project-euler.common sequences splitting ;
+USING: kernel namespaces project-euler.common sequences
+splitting grouping ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
! 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 sets ;
+ splitting grouping strings sets ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
#! Syntax: QUALIFIED-WITH: vocab prefix
scan scan define-qualified ; parsing
-: expect=> scan "=>" assert= ;
+: expect=> ( -- ) scan "=>" assert= ;
: partial-vocab ( words name -- assoc )
dupd [
USING: kernel math tools.test namespaces random
-random.blum-blum-shub alien.c-types sequences splitting ;
+random.blum-blum-shub alien.c-types sequences splitting
+grouping ;
IN: blum-blum-shub.tests
[ 887708070 ] [
: or-predicates ( quots -- quot )
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-: <@literal [ nip ] curry <@ ;
+: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
-: <@delay [ curry ] curry <@ ;
+: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
PRIVATE>
'posix-character-class' <|>
'simple-escape' <|> &> ;
-: 'any-char'
+: 'any-char' ( -- parser )
"." token [ drop t ] <@literal ;
-: 'char'
+: 'char' ( -- parser )
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
DEFER: 'regexp'
+++ /dev/null
-USING: kernel peg regexp2 sequences tools.test ;
-IN: regexp2.tests
-
-[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
- [ "056" 'octal' parse ] unit-test
+++ /dev/null
-USING: assocs combinators.lib kernel math math.parser
-namespaces peg unicode.case sequences unicode.categories
-memoize peg.parsers math.order ;
-USE: io
-USE: tools.walker
-IN: regexp2
-
-<PRIVATE
-
-SYMBOL: ignore-case?
-
-: char=-quot ( ch -- quot )
- ignore-case? get
- [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
- curry ;
-
-: char-between?-quot ( ch1 ch2 -- quot )
- ignore-case? get
- [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
- [ [ between? ] ]
- if 2curry ;
-
-: or-predicates ( quots -- quot )
- [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-
-: literal-action [ nip ] curry action ;
-
-: delay-action [ curry ] curry action ;
-
-PRIVATE>
-
-: ascii? ( n -- ? )
- 0 HEX: 7f between? ;
-
-: octal-digit? ( n -- ? )
- CHAR: 0 CHAR: 7 between? ;
-
-: hex-digit? ( n -- ? )
- {
- [ dup digit? ]
- [ dup CHAR: a CHAR: f between? ]
- [ dup CHAR: A CHAR: F between? ]
- } || nip ;
-
-: control-char? ( n -- ? )
- { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
-
-: punct? ( n -- ? )
- "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
- { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
-
-: java-blank? ( n -- ? )
- {
- CHAR: \s
- CHAR: \t CHAR: \n CHAR: \r
- HEX: c HEX: 7 HEX: 1b
- } member? ;
-
-: java-printable? ( n -- ? )
- { [ dup alpha? ] [ dup punct? ] } || nip ;
-
-MEMO: 'ordinary-char' ( -- parser )
- [ "\\^*+?|(){}[$" member? not ] satisfy
- [ char=-quot ] action ;
-
-MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
-
-MEMO: 'octal' ( -- parser )
- "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
- [ first oct> ] action ;
-
-MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
-
-MEMO: 'hex' ( -- parser )
- "x" token hide 'hex-digit' 2 exactly-n 2seq
- "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
- [ first hex> ] action ;
-
-: satisfy-tokens ( assoc -- parser )
- [ >r token r> literal-action ] { } assoc>map choice ;
-
-MEMO: 'simple-escape-char' ( -- parser )
- {
- { "\\" CHAR: \\ }
- { "t" CHAR: \t }
- { "n" CHAR: \n }
- { "r" CHAR: \r }
- { "f" HEX: c }
- { "a" HEX: 7 }
- { "e" HEX: 1b }
- } [ char=-quot ] assoc-map satisfy-tokens ;
-
-MEMO: 'predefined-char-class' ( -- parser )
- {
- { "d" [ digit? ] }
- { "D" [ digit? not ] }
- { "s" [ java-blank? ] }
- { "S" [ java-blank? not ] }
- { "w" [ c-identifier-char? ] }
- { "W" [ c-identifier-char? not ] }
- } satisfy-tokens ;
-
-MEMO: 'posix-character-class' ( -- parser )
- {
- { "Lower" [ letter? ] }
- { "Upper" [ LETTER? ] }
- { "ASCII" [ ascii? ] }
- { "Alpha" [ Letter? ] }
- { "Digit" [ digit? ] }
- { "Alnum" [ alpha? ] }
- { "Punct" [ punct? ] }
- { "Graph" [ java-printable? ] }
- { "Print" [ java-printable? ] }
- { "Blank" [ " \t" member? ] }
- { "Cntrl" [ control-char? ] }
- { "XDigit" [ hex-digit? ] }
- { "Space" [ java-blank? ] }
- } satisfy-tokens "p{" "}" surrounded-by ;
-
-MEMO: 'simple-escape' ( -- parser )
- [
- 'octal' ,
- 'hex' ,
- "c" token hide [ LETTER? ] satisfy 2seq ,
- any-char ,
- ] choice* [ char=-quot ] action ;
-
-MEMO: 'escape' ( -- parser )
- "\\" token hide [
- 'simple-escape-char' ,
- 'predefined-char-class' ,
- 'posix-character-class' ,
- 'simple-escape' ,
- ] choice* 2seq ;
-
-MEMO: 'any-char' ( -- parser )
- "." token [ drop t ] literal-action ;
-
-MEMO: 'char' ( -- parser )
- 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
-
-DEFER: 'regexp'
-
-TUPLE: group-result str ;
-
-C: <group-result> group-result
-
-MEMO: 'non-capturing-group' ( -- parser )
- "?:" token hide 'regexp' ;
-
-MEMO: 'positive-lookahead-group' ( -- parser )
- "?=" token hide 'regexp' [ ensure ] action ;
-
-MEMO: 'negative-lookahead-group' ( -- parser )
- "?!" token hide 'regexp' [ ensure-not ] action ;
-
-MEMO: 'simple-group' ( -- parser )
- 'regexp' [ [ <group-result> ] action ] action ;
-
-MEMO: 'group' ( -- parser )
- [
- 'non-capturing-group' ,
- 'positive-lookahead-group' ,
- 'negative-lookahead-group' ,
- 'simple-group' ,
- ] choice* "(" ")" surrounded-by ;
-
-MEMO: 'range' ( -- parser )
- any-char "-" token hide any-char 3seq
- [ first2 char-between?-quot ] action ;
-
-MEMO: 'character-class-term' ( -- parser )
- 'range'
- 'escape'
- [ "\\]" member? not ] satisfy [ char=-quot ] action
- 3choice ;
-
-MEMO: 'positive-character-class' ( -- parser )
- ! todo
- "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
- 'character-class-term' repeat1 2choice [ or-predicates ] action ;
-
-MEMO: 'negative-character-class' ( -- parser )
- "^" token hide 'positive-character-class' 2seq
- [ [ not ] append ] action ;
-
-MEMO: 'character-class' ( -- parser )
- 'negative-character-class' 'positive-character-class' 2choice
- "[" "]" surrounded-by [ satisfy ] action ;
-
-MEMO: 'escaped-seq' ( -- parser )
- any-char repeat1
- [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
-
-MEMO: 'break' ( quot -- parser )
- satisfy ensure
- epsilon just 2choice ;
-
-MEMO: 'break-escape' ( -- parser )
- "$" token [ "\r\n" member? ] 'break' literal-action
- "\\b" token [ blank? ] 'break' literal-action
- "\\B" token [ blank? not ] 'break' literal-action
- "\\z" token epsilon just literal-action 4choice ;
-
-MEMO: 'simple' ( -- parser )
- [
- 'escaped-seq' ,
- 'break-escape' ,
- 'group' ,
- 'character-class' ,
- 'char' ,
- ] choice* ;
-
-MEMO: 'exactly-n' ( -- parser )
- 'integer' [ exactly-n ] delay-action ;
-
-MEMO: 'at-least-n' ( -- parser )
- 'integer' "," token hide 2seq [ at-least-n ] delay-action ;
-
-MEMO: 'at-most-n' ( -- parser )
- "," token hide 'integer' 2seq [ at-most-n ] delay-action ;
-
-MEMO: 'from-m-to-n' ( -- parser )
- 'integer' "," token hide 'integer' 3seq
- [ first2 from-m-to-n ] delay-action ;
-
-MEMO: 'greedy-interval' ( -- parser )
- 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
-
-MEMO: 'interval' ( -- parser )
- 'greedy-interval'
- 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
- 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
- 3choice "{" "}" surrounded-by ;
-
-MEMO: 'repetition' ( -- parser )
- [
- ! Possessive
- ! "*+" token [ <!*> ] literal-action ,
- ! "++" token [ <!+> ] literal-action ,
- ! "?+" token [ <!?> ] literal-action ,
- ! Reluctant
- ! "*?" token [ <(*)> ] literal-action ,
- ! "+?" token [ <(+)> ] literal-action ,
- ! "??" token [ <(?)> ] literal-action ,
- ! Greedy
- "*" token [ repeat0 ] literal-action ,
- "+" token [ repeat1 ] literal-action ,
- "?" token [ optional ] literal-action ,
- ] choice* ;
-
-MEMO: 'dummy' ( -- parser )
- epsilon [ ] literal-action ;
-
-! todo -- check the action
-! MEMO: 'term' ( -- parser )
- ! 'simple'
- ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
- ! <!+> [ <and-parser> ] action ;
-
{ spread 2 }\r
} at 0 or ;\r
\r
-: vsum { 0 0 } [ v+ ] reduce ;\r
+: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;\r
\r
GENERIC: noise ( obj -- pair )\r
\r
\r
M: array noise [ noise ] map vsum ;\r
\r
-: noise-factor / 100 * >integer ;\r
+: noise-factor ( x y -- z ) / 100 * >integer ;\r
\r
: quot-noise-factor ( quot -- n )\r
#! For very short words, noise doesn't count so much\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ,, building get peek push ;
-: v, V{ } clone , ;
-: ,v building get dup peek empty? [ dup pop* ] when drop ;
+: ,, ( obj -- ) building get peek push ;
+: v, ( -- ) V{ } clone , ;
+: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
gadget.
] ($block) ;
-: page-theme
+: page-theme ( gadget -- )
T{ gradient f { { 0.8 0.8 1.0 1.0 } { 0.8 1.0 1.0 1.0 } } }
swap set-gadget-interior ;
call
] with-client ; inline
-: crlf "\r\n" write ;
+: crlf ( -- ) "\r\n" write ;
: command ( string -- ) write crlf flush ;
TUPLE: state place data ;
-TUPLE: missing-state ;
-: missing-state \ missing-state new throw ;
+ERROR: missing-state ;
+
M: missing-state error.
drop "Missing state" print ;
] with-string-writer ;\r
\r
TUPLE: unexpected-end < parsing-error ;\r
-: unexpected-end \ unexpected-end parsing-error throw ;\r
+: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;\r
M: unexpected-end summary ( obj -- str )\r
[\r
call-next-method write\r
] with-string-writer ;\r
\r
TUPLE: missing-close < parsing-error ;\r
-: missing-close \ missing-close parsing-error throw ;\r
+: missing-close ( -- * ) \ missing-close parsing-error throw ;\r
M: missing-close summary ( obj -- str )\r
[\r
call-next-method write\r
[ dup get-char = ] take-until nip ;\r
\r
TUPLE: not-enough-characters < parsing-error ;\r
-: not-enough-characters\r
+: not-enough-characters ( -- * )\r
\ not-enough-characters parsing-error throw ;\r
M: not-enough-characters summary ( obj -- str )\r
[\r
SYMBOL: solutions
SYMBOL: board
-: pair+ swapd + >r + r> ;
+: pair+ ( a b c d -- a+b c+d ) swapd + >r + r> ;
-: row board get nth ;
-: board> row nth ;
-: >board row set-nth ;
-: f>board f -rot >board ;
+: row ( n -- row ) board get nth ;
+: board> ( m n -- x ) row nth ;
+: >board ( row m n -- ) row set-nth ;
+: f>board ( m n -- ) f -rot >board ;
: row-contains? ( n y -- ? ) row member? ;
: col-contains? ( n x -- ? ) board get swap <column> member? ;
: <tax-table> ( single married class -- obj )
>r tax-table boa r> construct-delegate ;
-: tax-bracket-range dup second swap first - ;
+: tax-bracket-range ( pair -- n ) dup second swap first - ;
: tax-bracket ( tax salary triples -- tax salary )
[ [ tax-bracket-range min ] keep third * + ] 2keep
my-boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
-: ?, [ , ] [ drop ] if ;
-
: bootstrap-profile ( -- profile )
- [
- "math" deploy-math? get ?,
- "compiler" deploy-compiler? get ?,
- "ui" deploy-ui? get ?,
- "io" native-io? ?,
- "random" deploy-random? get ?,
- ] { } make ;
+ {
+ { "math" deploy-math? }
+ { "compiler" deploy-compiler? }
+ { "ui" deploy-ui? }
+ { "random" deploy-random? }
+ } [ nip get ] assoc-filter keys
+ native-io? [ "io" suffix ] when ;
: staging-image-name ( profile -- name )
"staging."
{ 3 "Level 3 - Non-blocking streams and networking" }
} ;
-: strip-io? deploy-io get 1 = ;
+: strip-io? ( -- ? ) deploy-io get 1 = ;
-: native-io? deploy-io get 3 = ;
+: native-io? ( -- ? ) deploy-io get 3 = ;
SYMBOL: deploy-reflection
{ 6 "Level 6 - Full environment" }
} ;
-: strip-word-names? deploy-reflection get 2 < ;
-: strip-prettyprint? deploy-reflection get 3 < ;
-: strip-debugger? deploy-reflection get 4 < ;
-: strip-dictionary? deploy-reflection get 5 < ;
-: strip-globals? deploy-reflection get 6 < ;
+: strip-word-names? ( -- ? ) deploy-reflection get 2 < ;
+: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ;
+: strip-debugger? ( -- ? ) deploy-reflection get 4 < ;
+: strip-dictionary? ( -- ? ) deploy-reflection get 5 < ;
+: strip-globals? ( -- ? ) deploy-reflection get 6 < ;
SYMBOL: deploy-word-props?
SYMBOL: deploy-word-defs?
IN: tools.deploy.test.1\r
USING: threads ;\r
\r
-: deploy-test-1 1000 sleep ;\r
+: deploy-test-1 ( -- ) 1000 sleep ;\r
\r
MAIN: deploy-test-1\r
IN: tools.deploy.test.2\r
USING: calendar calendar.format ;\r
\r
-: deploy-test-2 now (timestamp>string) ;\r
+: deploy-test-2 ( -- ) now (timestamp>string) ;\r
\r
MAIN: deploy-test-2\r
IN: tools.deploy.test.3\r
USING: io.encodings.ascii io.files kernel ;\r
\r
-: deploy-test-3\r
+: deploy-test-3 ( -- )\r
"resource:extra/tools/deploy/test/3/3.factor"\r
ascii file-contents drop ;\r
\r
generic ;
IN: tools.disassembler
-: in-file "gdb-in.txt" temp-file ;
+: in-file ( -- path ) "gdb-in.txt" temp-file ;
-: out-file "gdb-out.txt" temp-file ;
+: out-file ( -- path ) "gdb-out.txt" temp-file ;
GENERIC: make-disassemble-cmd ( obj -- )
! 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 combinators ;
+system sorting splitting grouping math.parser classes memory
+combinators ;
IN: tools.memory
<PRIVATE
[ ] [ \ + usage-profile. ] unit-test
-: callback-test "void" { } "cdecl" [ ] alien-callback ;
+: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
-: indirect-test "void" { } "cdecl" alien-indirect ;
+: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
: foobar ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.vectors memory io io.styles prettyprint
-namespaces system sequences splitting assocs strings ;
+namespaces system sequences splitting grouping assocs strings ;
IN: tools.time
: benchmark ( quot -- runtime )
: (step-into-quot) ( quot -- ) add-breakpoint call ;
-: (step-into-if) ? (step-into-quot) ;
+: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-: (step-into-dispatch) nth (step-into-quot) ;
+: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
{
\ (step-into-execute) t "step-into?" set-word-prop
-: (step-into-continuation)
+: (step-into-continuation) ( -- )
continuation callstack >>call break ;
! Messages sent to walker thread
! For convenience
IN: syntax
-: B break ;
+: B ( -- ) break ;
: get-largest ( node -- node )
dup [ dup node-right [ nip get-largest ] when* ] when ;
-: splay-largest
+: splay-largest ( node -- node )
dup [ dup get-largest node-key swap splay-at ] when ;
: splay-join ( n2 n1 -- node )
: valid-tree? ( tree -- ? ) root>> valid-node? ;
-: tree-call ( node call -- )
- >r [ node-key ] keep node-value r> call ; inline
-
-: find-node ( node quot -- key value ? )
- {
- { [ over not ] [ 2drop f f f ] }
- { [ [
- >r left>> r> find-node
- ] 2keep rot ]
- [ 2drop t ] }
- { [ >r 2nip r> [ tree-call ] 2keep rot ]
- [ drop [ node-key ] keep node-value t ] }
- [ >r right>> r> find-node ]
- } cond ; inline
-
-M: tree assoc-find ( tree quot -- key value ? )
- >r root>> r> find-node ;
+: (node>alist) ( node -- )
+ [
+ [ left>> (node>alist) ]
+ [ [ node-key ] [ node-value ] bi 2array , ]
+ [ right>> (node>alist) ]
+ tri
+ ] when* ;
+
+M: tree >alist [ root>> (node>alist) ] { } make ;
M: tree clear-assoc
0 >>count
"tty-server"
utf8 [ listener ] with-server ;
-: default-tty-server 9999 tty-server ;
+: default-tty-server ( -- ) 9999 tty-server ;
MAIN: default-tty-server
IN: tuple-arrays
HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ;
+{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ;
HELP: <tuple-array>
{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be f." } ;
+{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ;
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting classes.tuple classes math kernel sequences
-arrays ;
+USING: splitting grouping classes.tuple classes math kernel
+sequences arrays ;
IN: tuple-arrays
TUPLE: tuple-array example ;
dup state-dir position [ + ] change
state-next state set ;
-: c
+: c ( -- )
#! Print current turing machine state.
state get .
tape get .
2 position get 2 * + CHAR: \s <string> write "^" print ;
-: n
+: n ( -- )
#! Do one step and print new state.
turing-step c ;
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard boa ;
+: <clipboard> ( -- clipboard ) "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
2drop
] if ;
-: com-copy clipboard get gadget-copy ;
+: com-copy ( gadget -- ) clipboard get gadget-copy ;
-: com-copy-selection selection get gadget-copy ;
+: com-copy-selection ( gadget -- ) selection get gadget-copy ;
arrays assocs ;
IN: ui.commands
-: command-map-row
+: command-map-row ( children -- seq )
[
- dup first gesture>string ,
- second dup command-name ,
- dup command-word \ $link swap 2array ,
- command-description ,
- ] [ ] make ;
+ [ first gesture>string , ]
+ [
+ second
+ [ command-name , ]
+ [ command-word \ $link swap 2array , ]
+ [ command-description , ]
+ tri
+ ] bi
+ ] { } make ;
: command-map. ( command-map -- )
[ command-map-row ] map
$table ;
: $command-map ( element -- )
- first2
- dup (command-name) " commands" append $heading
- swap command-map
- dup command-map-blurb print-element command-map. ;
+ [ second (command-name) " commands" append $heading ]
+ [
+ first2 swap command-map
+ [ command-map-blurb print-element ] [ command-map. ] bi
+ ] bi ;
: $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.commands ui.gadgets ui.gadgets.borders
+USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
C: <button-paint> button-paint
-: find-button [ [ button? ] is? ] find-parent ;
+: find-button ( gadget -- button )
+ [ [ button? ] is? ] find-parent ;
: button-paint ( button paint -- button paint )
over find-button {
: toggle-model ( model -- )
[ not ] change-model ;
-: checkbox-theme
- f over set-gadget-interior
- { 5 5 } over set-pack-gap
- 1/2 swap set-pack-align ;
+: checkbox-theme ( gadget -- )
+ f >>interior
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
TUPLE: checkbox ;
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
-: radio-button-theme
- { 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
+: radio-button-theme ( gadget -- )
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right
[ <button> ] <radio-control>
dup radio-button-theme ;
-: radio-buttons-theme
- { 5 5 } swap set-pack-gap ;
+: radio-buttons-theme ( gadget -- )
+ { 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
-: contents-changed
+: contents-changed ( model editor -- )
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
-: caret/mark-changed
+: caret/mark-changed ( model editor -- )
nip editor-self dup relayout-1 scroll>caret ;
M: editor model-changed
[ drop dup extend-selection dup editor-mark click-loc ]
[ select-elt ] if ;
-: insert-newline "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input ;
-: delete-next-character T{ char-elt } editor-delete ;
+: delete-next-character ( editor -- )
+ T{ char-elt } editor-delete ;
-: delete-previous-character T{ char-elt } editor-backspace ;
+: delete-previous-character ( editor -- )
+ T{ char-elt } editor-backspace ;
-: delete-previous-word T{ word-elt } editor-delete ;
+: delete-previous-word ( editor -- )
+ T{ word-elt } editor-delete ;
-: delete-next-word T{ word-elt } editor-backspace ;
+: delete-next-word ( editor -- )
+ T{ word-elt } editor-backspace ;
-: delete-to-start-of-line T{ one-line-elt } editor-delete ;
+: delete-to-start-of-line ( editor -- )
+ T{ one-line-elt } editor-delete ;
-: delete-to-end-of-line T{ one-line-elt } editor-backspace ;
+: delete-to-end-of-line ( editor -- )
+ T{ one-line-elt } editor-backspace ;
editor "general" f {
{ T{ key-down f f "DELETE" } delete-next-character }
{ T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
} define-command-map
-: paste clipboard get paste-clipboard ;
+: paste ( editor -- ) clipboard get paste-clipboard ;
-: paste-selection selection get paste-clipboard ;
+: paste-selection ( editor -- ) selection get paste-clipboard ;
-: cut clipboard get editor-cut ;
+: cut ( editor -- ) clipboard get editor-cut ;
editor "clipboard" f {
{ T{ paste-action } paste }
T{ char-elt } editor-next
] if ;
-: previous-line T{ line-elt } editor-prev ;
+: previous-line ( editor -- ) T{ line-elt } editor-prev ;
-: next-line T{ line-elt } editor-next ;
+: next-line ( editor -- ) T{ line-elt } editor-next ;
-: previous-word T{ word-elt } editor-prev ;
+: previous-word ( editor -- ) T{ word-elt } editor-prev ;
-: next-word T{ word-elt } editor-next ;
+: next-word ( editor -- ) T{ word-elt } editor-next ;
-: start-of-line T{ one-line-elt } editor-prev ;
+: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-: end-of-line T{ one-line-elt } editor-next ;
+: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
editor "caret-motion" f {
{ T{ button-down } position-caret }
{ T{ key-down f { C+ } "END" } end-of-document }
} define-command-map
-: select-all T{ doc-elt } select-elt ;
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
-: select-line T{ one-line-elt } select-elt ;
+: select-line ( editor -- ) T{ one-line-elt } select-elt ;
-: select-word T{ one-word-elt } select-elt ;
+: select-word ( editor -- ) T{ one-word-elt } select-elt ;
: selected-word ( editor -- string )
dup gadget-selection?
[ dup select-word ] unless
gadget-selection ;
-: select-previous-character T{ char-elt } editor-select-prev ;
+: select-previous-character ( editor -- )
+ T{ char-elt } editor-select-prev ;
-: select-next-character T{ char-elt } editor-select-next ;
+: select-next-character ( editor -- )
+ T{ char-elt } editor-select-next ;
-: select-previous-line T{ line-elt } editor-select-prev ;
+: select-previous-line ( editor -- )
+ T{ line-elt } editor-select-prev ;
-: select-next-line T{ line-elt } editor-select-next ;
+: select-next-line ( editor -- )
+ T{ line-elt } editor-select-next ;
-: select-previous-word T{ word-elt } editor-select-prev ;
+: select-previous-word ( editor -- )
+ T{ word-elt } editor-select-prev ;
-: select-next-word T{ word-elt } editor-select-next ;
+: select-next-word ( editor -- )
+ T{ word-elt } editor-select-next ;
-: select-start-of-line T{ one-line-elt } editor-select-prev ;
+: select-start-of-line ( editor -- )
+ T{ one-line-elt } editor-select-prev ;
-: select-end-of-line T{ one-line-elt } editor-select-next ;
+: select-end-of-line ( editor -- )
+ T{ one-line-elt } editor-select-next ;
-: select-start-of-document T{ doc-elt } editor-select-prev ;
+: select-start-of-document ( editor -- )
+ T{ doc-elt } editor-select-prev ;
-: select-end-of-document T{ doc-elt } editor-select-next ;
+: select-end-of-document ( editor -- )
+ T{ doc-elt } editor-select-next ;
editor "selection" f {
{ T{ button-down f { S+ } } extend-selection }
-USING: kernel alien.c-types combinators sequences splitting
+USING: kernel alien.c-types combinators sequences splitting grouping
opengl.gl ui.gadgets ui.render
math math.vectors accessors ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
-splitting math.vectors ui.gadgets.grids ui.gadgets ;
+splitting grouping math.vectors ui.gadgets.grids ui.gadgets ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
TUPLE: frame ;
-: <frame-grid> 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
: @center 1 1 ;
: @left 0 1 ;
dup gadget-layout-state
[ drop ] [ dup invalidate layout-later ] if ;
-: show-gadget t swap set-gadget-visible? ;
+: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
-: hide-gadget f swap set-gadget-visible? ;
+: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
: (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim =
dup [ layout ] each-child
] when drop ;
-: graft-queue \ graft-queue get ;
+: graft-queue ( -- dlist ) \ graft-queue get ;
: unqueue-graft ( gadget -- )
graft-queue over gadget-graft-node delete-node
SYMBOL: in-layout?
-: not-in-layout
+: not-in-layout ( -- )
in-layout? get
[ "Cannot add/remove gadgets in layout*" throw ] when ;
: pref-dim-grid ( grid -- dims )
grid-children [ [ pref-dim ] map ] map ;
-: (compute-grid) [ max-dim ] map ;
+: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
{ 0.65 0.45 1.0 1.0 }
} } swap set-gadget-interior ;
-: <title-label> <label> dup title-theme ;
+: <title-label> ( text -- label ) <label> dup title-theme ;
: <title-bar> ( title quot -- gadget )
[
selection-color caret mark selecting? ;
: clear-selection ( pane -- )
- f over set-pane-caret
- f swap set-pane-mark ;
+ f >>caret
+ f >>mark
+ drop ;
-: add-output 2dup set-pane-output add-gadget ;
+: add-output ( current pane -- )
+ [ set-pane-output ] [ add-gadget ] 2bi ;
-: add-current 2dup set-pane-current add-gadget ;
+: add-current ( current pane -- )
+ [ set-pane-current ] [ add-gadget ] 2bi ;
: prepare-line ( pane -- )
- dup clear-selection
- dup pane-prototype clone swap add-current ;
+ [ clear-selection ]
+ [ [ pane-prototype clone ] keep add-current ] bi ;
: pane-caret&mark ( pane -- caret mark )
- dup pane-caret swap pane-mark ;
+ [ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
selected-children gadget-text ;
: pane-clear ( pane -- )
- dup clear-selection
- dup pane-output clear-incremental
- pane-current clear-gadget ;
+ [ clear-selection ]
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ tri ;
-: pane-theme ( editor -- )
- selection-color swap set-pane-selection-color ;
+: pane-theme ( pane -- )
+ selection-color >>selection-color drop ;
: <pane> ( -- pane )
pane new
<pile> over set-delegate
- <shelf> over set-pane-prototype
+ <shelf> >>prototype
<pile> <incremental> over add-output
dup prepare-line
dup pane-theme ;
: overrun? ( width -- ? ) x get + margin get > ;
-: zero-vars [ 0 swap set ] each ;
+: zero-vars ( seq -- ) [ 0 swap set ] each ;
: wrap-line ( -- )
line-height get y +@
: find-scroller ( gadget -- scroller/f )
[ [ scroller? ] is? ] find-parent ;
-: scroll-up-page scroller-y -1 swap slide-by-page ;
+: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
-: scroll-down-page scroller-y 1 swap slide-by-page ;
+: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
-: scroll-up-line scroller-y -1 swap slide-by-line ;
+: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
-: scroll-down-line scroller-y 1 swap slide-by-line ;
+: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
scroll-direction get-global first2
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-: x-model g gadget-model model-dependencies first ;
+: x-model ( -- model ) g gadget-model model-dependencies first ;
-: y-model g gadget-model model-dependencies second ;
+: y-model ( -- model ) g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [
: min-thumb-dim 15 ;
-: slider-value gadget-model range-value >fixnum ;
+: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-: slider-page gadget-model range-page-value ;
+: slider-page ( gadget -- n ) gadget-model range-page-value ;
-: slider-max gadget-model range-max-value ;
+: slider-max ( gadget -- n ) gadget-model range-max-value ;
-: slider-max* gadget-model range-max-value* ;
+: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
dup elevator-length over thumb-dim - 1 max
swap slider-max* 1 max / ;
-: slider>screen slider-scale * ;
+: slider>screen ( m scale -- n ) slider-scale * ;
-: screen>slider slider-scale / ;
+: screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ;
swap <thumb> g-> set-slider-thumb over add-gadget
@center frame, ;
-: <left-button> { 0 1 } arrow-left -1 <slide-button> ;
-: <right-button> { 0 1 } arrow-right 1 <slide-button> ;
+: <left-button> ( -- button )
+ { 0 1 } arrow-left -1 <slide-button> ;
+
+: <right-button> ( -- button )
+ { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- )
[
<right-button> @right frame,
] with-gadget ;
-: <up-button> { 1 0 } arrow-up -1 <slide-button> ;
-: <down-button> { 1 0 } arrow-down 1 <slide-button> ;
+: <up-button> ( -- button )
+ { 1 0 } arrow-up -1 <slide-button> ;
+
+: <down-button> ( -- button )
+ { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- )
[
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
colors ;
IN: ui.gadgets.theme
-: solid-interior <solid> swap set-gadget-interior ;
+: solid-interior ( gadget color -- )
+ <solid> swap set-gadget-interior ;
-: solid-boundary <solid> swap set-gadget-boundary ;
+: solid-boundary ( gadget color -- )
+ <solid> swap set-gadget-boundary ;
-: faint-boundary gray solid-boundary ;
+: faint-boundary ( gadget -- )
+ gray solid-boundary ;
-: selection-color light-purple ;
+: selection-color ( -- color ) light-purple ;
: plain-gradient
T{ gradient f {
TUPLE: viewport ;
-: find-viewport [ viewport? ] find-parent ;
+: find-viewport ( gadget -- viewport )
+ [ viewport? ] find-parent ;
: viewport-dim ( viewport -- dim )
gadget-child pref-dim viewport-gap 2 v*n v+ ;
fonts handle
loc ;
-: find-world [ world? ] find-parent ;
+: find-world ( gadget -- world ) [ world? ] find-parent ;
M: f world-status ;
C: <solid> solid
! Solid pen
-: (solid)
+: (solid) ( gadget paint -- loc dim )
solid-color gl-color rect-dim >r origin get dup r> v+ ;
M: solid draw-interior (solid) gl-fill-rect ;
USING: debugger ui.tools.workspace help help.topics kernel
models ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs ;
+ui.gadgets.buttons compiler.units assocs words vocabs
+accessors ;
IN: ui.tools.browser
TUPLE: browser-gadget pane history ;
: show-help ( link help -- )
- dup browser-gadget-history add-history
- >r >link r> browser-gadget-history set-model ;
+ dup history>> add-history
+ >r >link r> history>> set-model ;
: <help-pane> ( browser-gadget -- gadget )
- browser-gadget-history
- [ [ dup help ] try drop ] <pane-control> ;
+ history>> [ [ dup help ] try drop ] <pane-control> ;
: init-history ( browser-gadget -- )
- "handbook" >link <history>
- swap set-browser-gadget-history ;
+ "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
browser-gadget new
M: browser-gadget call-tool* show-help ;
M: browser-gadget tool-scroller
- browser-gadget-pane find-scroller ;
+ pane>> find-scroller ;
M: browser-gadget graft*
dup add-definition-observer
or or ;
M: browser-gadget definitions-changed ( assoc browser -- )
- browser-gadget-history
+ history>>
dup model-value rot showing-definition?
[ notify-connections ] [ drop ] if ;
: help-action ( browser-gadget -- link )
- browser-gadget-history model-value >link ;
+ history>> model-value >link ;
-: com-follow browser-gadget call-tool ;
+: com-follow ( link -- ) browser-gadget call-tool ;
-: com-back browser-gadget-history go-back ;
+: com-back ( browser -- ) history>> go-back ;
-: com-forward browser-gadget-history go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
-: com-documentation "handbook" swap show-help ;
+: com-documentation ( browser -- ) "handbook" swap show-help ;
-: com-vocabularies "vocab-index" swap show-help ;
+: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-: browser-help "ui-browser" help-window ;
+: browser-help ( -- ) "ui-browser" help-window ;
\ browser-help H{ { +nullary+ t } } define-command
{ T{ button-down } request-focus }
} define-command-map
-: com-traceback error-continuation get traceback-window ;
+: com-traceback ( -- ) error-continuation get traceback-window ;
\ com-traceback H{ { +nullary+ t } } define-command
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system ;
+tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ;
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
-: deploy-settings-theme
- { 10 10 } over set-pack-gap
- 1 swap set-pack-fill ;
+: deploy-settings-theme ( gadget -- )
+ { 10 10 } >>gap
+ 1 >>fill
+ drop ;
: <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map [
namespace <mapping> over set-gadget-model
] bind ;
-: find-deploy-gadget
+: find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ;
-: find-deploy-vocab
+: find-deploy-vocab ( gadget -- vocab )
find-deploy-gadget deploy-gadget-vocab ;
-: find-deploy-config
+: find-deploy-config ( gadget -- config )
find-deploy-vocab deploy-config ;
-: find-deploy-settings
+: find-deploy-settings ( gadget -- settings )
find-deploy-gadget deploy-gadget-settings ;
: com-revert ( gadget -- )
{ T{ key-down f f "RET" } com-deploy }
} define-command-map
-: buttons,
+: buttons, ( -- )
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
\ globals H{ { +nullary+ t } { +listener+ t } } define-command
-: inspector-help "ui-inspector" help-window ;
+: inspector-help ( -- ) "ui-inspector" help-window ;
\ inspector-help H{ { +nullary+ t } } define-command
listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
-: listener-help "ui-listener" help-window ;
+: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
-tools.vocabs classes compiler.units ;
+tools.vocabs classes compiler.units accessors ;
IN: ui.tools.operations
V{ } clone operations set-global
{ +listener+ t }
} define-operation
-: com-prettyprint . ;
+: com-prettyprint ( obj -- ) . ;
[ drop t ] \ com-prettyprint H{
{ +listener+ t }
} define-operation
-: com-push ;
+: com-push ( obj -- obj ) ;
[ drop t ] \ com-push H{
{ +listener+ t }
} define-operation
-: com-unparse unparse listener-input ;
+: com-unparse ( obj -- ) unparse listener-input ;
[ drop t ] \ com-unparse H{ } define-operation
! Input
-: com-input input-string listener-input ;
+: com-input ( obj -- ) string>> listener-input ;
[ input? ] \ com-input H{
{ +primary+ t }
} define-operation
! Pathnames
-: edit-file edit ;
+: edit-file ( pathname -- ) edit ;
[ pathname? ] \ edit-file H{
{ +keyboard+ T{ key-down f { C+ } "E" } }
} define-operation
! Vocabularies
-: com-vocab-words get-workspace swap show-vocab-words ;
+: com-vocab-words ( vocab -- )
+ get-workspace swap show-vocab-words ;
[ vocab? ] \ com-vocab-words H{
{ +secondary+ t }
{ +keyboard+ T{ key-down f { C+ } "B" } }
} define-operation
-: com-enter-in vocab-name set-in ;
+: com-enter-in ( vocab -- ) vocab-name set-in ;
[ vocab? ] \ com-enter-in H{
{ +keyboard+ T{ key-down f { C+ } "I" } }
{ +listener+ t }
} define-operation
-: com-use-vocab vocab-name use+ ;
+: com-use-vocab ( vocab -- ) vocab-name use+ ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }
{ +listener+ t }
} define-operation
-: com-show-profile profiler-gadget call-tool ;
+: com-show-profile ( workspace -- )
+ profiler-gadget call-tool ;
: com-profile ( quot -- ) profile f com-show-profile ;
: com-method-profile ( gadget -- )
[ method-profile. ] with-profiler-pane ;
-: profiler-help "ui-profiler" help-window ;
+: profiler-help ( -- ) "ui-profiler" help-window ;
\ profiler-help H{ { +nullary+ t } } define-command
2drop t
] if ;
-: find-live-search [ [ live-search? ] is? ] find-parent ;
+: find-live-search ( gadget -- search )
+ [ [ live-search? ] is? ] find-parent ;
-: find-search-list find-live-search live-search-list ;
+: find-search-list ( gadget -- list )
+ find-live-search live-search-list ;
TUPLE: search-field ;
[ workspace-window ] ui-hook set-global
-: com-listener stack-display select-tool ;
+: com-listener ( workspace -- ) stack-display select-tool ;
-: com-browser browser-gadget select-tool ;
+: com-browser ( workspace -- ) browser-gadget select-tool ;
-: com-inspector inspector-gadget select-tool ;
+: com-inspector ( workspace -- ) inspector-gadget select-tool ;
-: com-profiler profiler-gadget select-tool ;
+: com-profiler ( workspace -- ) profiler-gadget select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
-: walker-help "ui-walker" help-window ;
+: walker-help ( -- ) "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
TUPLE: workspace book listener popup ;
-: find-workspace [ workspace? ] find-parent ;
+: find-workspace ( gadget -- workspace )
+ [ workspace? ] find-parent ;
SYMBOL: workspace-window-hook
-USING: io io.files splitting unicode.collation sequences kernel\r
-io.encodings.utf8 math.parser math.order tools.test assocs\r
-io.streams.null words combinators.lib ;\r
+USING: io io.files splitting grouping unicode.collation\r
+sequences kernel io.encodings.utf8 math.parser math.order\r
+tools.test assocs io.streams.null words combinators.lib ;\r
IN: unicode.collation.tests\r
\r
: parse-test ( -- strings )\r
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser hash2 math.order
+quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
io.encodings.ascii values interval-maps ascii sets assocs.lib
combinators.lib combinators locals math.ranges sorting ;
: cd ( n -- dimensioned ) { cd } { } <dimensioned> ;
! SI derived units
-: m^2 { m m } { } <dimensioned> ;
-: m^3 { m m m } { } <dimensioned> ;
-: m/s { m } { s } <dimensioned> ;
-: m/s^2 { m } { s s } <dimensioned> ;
-: 1/m { } { m } <dimensioned> ;
-: kg/m^3 { kg } { m m m } <dimensioned> ;
-: A/m^2 { A } { m m } <dimensioned> ;
-: A/m { A } { m } <dimensioned> ;
-: mol/m^3 { mol } { m m m } <dimensioned> ;
-: cd/m^2 { cd } { m m } <dimensioned> ;
-: kg/kg { kg } { kg } <dimensioned> ;
+: m^2 ( n -- dimensioned ) { m m } { } <dimensioned> ;
+: m^3 ( n -- dimensioned ) { m m m } { } <dimensioned> ;
+: m/s ( n -- dimensioned ) { m } { s } <dimensioned> ;
+: m/s^2 ( n -- dimensioned ) { m } { s s } <dimensioned> ;
+: 1/m ( n -- dimensioned ) { } { m } <dimensioned> ;
+: kg/m^3 ( n -- dimensioned ) { kg } { m m m } <dimensioned> ;
+: A/m^2 ( n -- dimensioned ) { A } { m m } <dimensioned> ;
+: A/m ( n -- dimensioned ) { A } { m } <dimensioned> ;
+: mol/m^3 ( n -- dimensioned ) { mol } { m m m } <dimensioned> ;
+: cd/m^2 ( n -- dimensioned ) { cd } { m m } <dimensioned> ;
+: kg/kg ( n -- dimensioned ) { kg } { kg } <dimensioned> ;
! Radians are really m/m, and steradians are m^2/m^2
! but they need to be in reduced form here.
: kat ( n -- katal ) { mol } { s } <dimensioned> ;
! Extensions to the SI
-: arc-deg pi 180 / * radians ;
-: arc-min pi 10800 / * radians ;
-: arc-sec pi 648000 / * radians ;
+: arc-deg ( n -- x ) pi 180 / * radians ;
+: arc-min ( n -- x ) pi 10800 / * radians ;
+: arc-sec ( n -- x ) pi 648000 / * radians ;
: L ( n -- liter ) 1/1000 * m^3 ;
: tons ( n -- metric-ton ) 1000 * kg ;
: Np ( n -- neper ) { } { } <dimensioned> ;
: bar ( n -- bar ) 100000 * Pa ;
: b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ;
: Ci ( n -- curie ) 37000000000 * Bq ;
-: R 258/10000 { s A } { kg } <dimensioned> ;
-: rad 100 / Gy ;
+: R ( -- dimensioned ) 258/10000 { s A } { kg } <dimensioned> ;
+: rad ( n -- dimensioned ) 100 / Gy ;
! roentgen equivalent man, equal to one roentgen of X-rays
-: roentgen-equivalent-man 100 / Sv ;
+: roentgen-equivalent-man ( n -- dimensioned ) 100 / Sv ;
! inaccurate, use calendar where possible
-: minutes 60 * s ;
-: hours 60 * minutes ;
-: days 24 * hours ;
+: minutes ( n -- dimensioned ) 60 * s ;
+: hours ( n -- dimensioned ) 60 * minutes ;
+: days ( n -- dimensioned ) 24 * hours ;
! Y Z E P T G M k h da 1 d c m mu n p f a z y
-: yotta 1000000000000000000000000 * ;
-: zetta 1000000000000000000000 * ;
-: exa 1000000000000000000 * ;
-: peta 1000000000000000 * ;
-: tera 1000000000000 * ;
-: giga 1000000000 * ;
-: mega 1000000 * ;
-: kilo 1000 * ;
-: hecto 100 * ;
-: deca 10 * ;
-: deci 10 / ;
-: centi 100 / ;
-: milli 1000 / ;
-: micro 1000000 / ;
-: nano 1000000000 / ;
-: pico 1000000000000 / ;
-: femto 1000000000000000 / ;
-: atto 1000000000000000000 / ;
-: zepto 1000000000000000000000 / ;
-: yocto 1000000000000000000000000 / ;
-
-: km kilo m ;
-: cm centi m ;
-: mm milli m ;
-: nm nano m ;
-: g milli kg ;
-: ms milli s ;
-: angstrom 10 / nm ;
+: yotta ( n -- x ) 1000000000000000000000000 * ;
+: zetta ( n -- x ) 1000000000000000000000 * ;
+: exa ( n -- x ) 1000000000000000000 * ;
+: peta ( n -- x ) 1000000000000000 * ;
+: tera ( n -- x ) 1000000000000 * ;
+: giga ( n -- x ) 1000000000 * ;
+: mega ( n -- x ) 1000000 * ;
+: kilo ( n -- x ) 1000 * ;
+: hecto ( n -- x ) 100 * ;
+: deca ( n -- x ) 10 * ;
+: deci ( n -- x ) 10 / ;
+: centi ( n -- x ) 100 / ;
+: milli ( n -- x ) 1000 / ;
+: micro ( n -- x ) 1000000 / ;
+: nano ( n -- x ) 1000000000 / ;
+: pico ( n -- x ) 1000000000000 / ;
+: femto ( n -- x ) 1000000000000000 / ;
+: atto ( n -- x ) 1000000000000000000 / ;
+: zepto ( n -- x ) 1000000000000000000000 / ;
+: yocto ( n -- x ) 1000000000000000000000000 / ;
+
+: km ( n -- dimensioned ) kilo m ;
+: cm ( n -- dimensioned ) centi m ;
+: mm ( n -- dimensioned ) milli m ;
+: nm ( n -- dimensioned ) nano m ;
+: g ( n -- dimensioned ) milli kg ;
+: ms ( n -- dimensioned ) milli s ;
+: angstrom ( n -- dimensioned ) 10 / nm ;
[ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
-: 2values [ dimensioned-value ] bi@ ;
+: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ;
-: <dimension-op
+: <dimension-op ( dim dim -- top bot val val )
2dup check-dimensions dup dimensions 2swap 2values ;
-: dimension-op>
+: dimension-op> ( top bot val -- dim )
-rot <dimensioned> ;
: d+ ( d d -- d ) <dimension-op + dimension-op> ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-: stat-st_atim stat-st_atimespec ;
-: stat-st_mtim stat-st_mtimespec ;
-: stat-st_ctim stat-st_ctimespec ;
+: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
+: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
+: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
-USING: kernel parser sequences words ;
+USING: kernel parser sequences words effects ;
IN: values
: VALUE:
- CREATE-WORD { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry
+ (( -- value )) define-declared ; parsing
: set-value ( value word -- )
word-def first set-first ;
! Thanks to Mackenzie Straight for the idea
-USING: compiler.units kernel parser words namespaces
-sequences quotations ;
+USING: kernel parser words namespaces sequences quotations ;
IN: vars
-: define-var-symbol ( str -- ) create-in define-symbol ;
+: define-var-getter ( word -- )
+ [ word-name ">" append create-in ] [ [ get ] curry ] bi
+ (( -- value )) define-declared ;
-: define-var-getter ( str -- )
-dup ">" append create-in swap in get lookup [ get ] curry define ;
+: define-var-setter ( word -- )
+ [ word-name ">" prepend create-in ] [ [ set ] curry ] bi
+ (( value -- )) define-declared ;
-: define-var-setter ( str -- )
-">" over append create-in swap in get lookup [ set ] curry define ;
-
-: define-var ( str -- ) [
-dup define-var-symbol dup define-var-getter define-var-setter
-] with-compilation-unit ;
+: define-var ( str -- )
+ create-in
+ [ define-symbol ]
+ [ define-var-getter ]
+ [ define-var-setter ] tri ;
: VAR: ! var
scan define-var ; parsing
-: define-vars ( seq -- ) [ define-var ] each ;
+: define-vars ( seq -- )
+ [ define-var ] each ;
: VARS: ! vars ...
-";" parse-tokens define-vars ; parsing
+ ";" parse-tokens define-vars ; parsing
: <post> ( id -- post ) \ post new swap >>id ;
-: init-posts-table \ post ensure-table ;
+: init-posts-table ( -- ) \ post ensure-table ;
TUPLE: comment < entity parent ;
swap >>id
swap >>parent ;
-: init-comments-table comment ensure-table ;
+: init-comments-table ( -- ) comment ensure-table ;
: post ( id -- post )
[ <post> select-tuple ] [ f <comment> select-tuples ] bi
webapps.user-admin ;
IN: webapps.factor-website
-: test-db "resource:test.db" sqlite-db ;
+: test-db ( -- db params ) "resource:test.db" sqlite-db ;
: init-factor-db ( -- )
test-db [
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-: init-pastes-table \ paste ensure-table ;
+: init-pastes-table ( -- ) \ paste ensure-table ;
-: init-annotations-table annotation ensure-table ;
+: init-annotations-table ( -- ) annotation ensure-table ;
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
-: init-blog-table blog ensure-table ;
+: init-blog-table ( -- ) blog ensure-table ;
-: init-postings-table posting ensure-table ;
+: init-postings-table ( -- ) posting ensure-table ;
: <blog> ( id -- todo )
blog new
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table todo ensure-table ;
+: init-todo-table ( -- ) todo ensure-table ;
: <todo> ( id -- todo )
todo new
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table article ensure-table ;
+: init-articles-table ( -- ) article ensure-table ;
TUPLE: revision id title author date content ;
: <revision> ( id -- revision )
revision new swap >>id ;
-: init-revisions-table revision ensure-table ;
+: init-revisions-table ( -- ) revision ensure-table ;
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
: 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_READ ( -- n ) STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
-: TOKEN_WRITE
+: TOKEN_WRITE ( -- n )
{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_DEFAULT
} flags ; foldable
-: TOKEN_ALL_ACCESS
+: TOKEN_ALL_ACCESS ( -- n )
{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
DWORD dwProvType,
DWORD dwFlags ) ;
-: CryptAcquireContext CryptAcquireContextW ;
+: CryptAcquireContext ( phProv pszContainer pszProvider dwProvType dwFlags -- BOOL )
+ CryptAcquireContextW ;
+
! : CryptContextAddRef ;
! : CryptCreateHash ;
! : CryptDecrypt ;
! : GetUserNameA ;
FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
-: GetUserName GetUserNameW ;
+: GetUserName ( lpBuffer lpnSize -- BOOL )
+ GetUserNameW ;
! : GetWindowsAccountDomainSid ;
! : I_ScIsSecurityProcess ;
FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
LPCTSTR lpName,
PLUID lpLuid ) ;
-: LookupPrivilegeValue LookupPrivilegeValueW ;
+: LookupPrivilegeValue ( lpSystemName lpname lpLuid -- BOOL )
+ LookupPrivilegeValueW ;
! : LookupSecurityDescriptorPartsA ;
! : LookupSecurityDescriptorPartsW ;
USING: alien alien.c-types kernel windows.ole32 combinators.lib
-parser splitting sequences.lib sequences namespaces assocs
-quotations shuffle accessors words macros alien.syntax fry ;
+parser splitting grouping sequences.lib sequences namespaces
+assocs quotations shuffle accessors words macros alien.syntax
+fry ;
IN: windows.com.syntax
<PRIVATE
DWORD dwMaximumSizeHigh,
DWORD dwMaximumSizeLow,
LPCTSTR lpName ) ;
-: CreateFileMapping CreateFileMappingW ;
+: CreateFileMapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) CreateFileMappingW ;
! FUNCTION: CreateHardLinkA
! FUNCTION: CreateHardLinkW
! FUNCTION: CreateMutexW
! FUNCTION: CreateNamedPipeA
FUNCTION: HANDLE CreateNamedPipeW ( LPCTSTR lpName, DWORD dwOpenMode, DWORD dwPipeMode, DWORD nMaxInstances, DWORD nOutBufferSize, DWORD nInBufferSize, DWORD nDefaultTimeOut, LPSECURITY_ATTRIBUTES lpSecurityAttributes ) ;
-: CreateNamedPipe CreateNamedPipeW ;
+: CreateNamedPipe ( lpName dwOpenMode dwPipeMode nMaxInstances nOutBufferSize nInBufferSize nDefaultTimeOut lpSecurityAttributes -- HANDLE ) CreateNamedPipeW ;
! FUNCTION: CreateNlsSecurityDescriptor
FUNCTION: BOOL CreatePipe ( PHANDLE hReadPipe, PHANDLE hWritePipe, LPSECURITY_ATTRIBUTES lpPipeAttributes, DWORD nSize ) ;
LPCTSTR lpCurrentDirectory,
LPSTARTUPINFO lpStartupInfo,
LPPROCESS_INFORMATION lpProcessInformation ) ;
-: CreateProcess CreateProcessW ;
+: CreateProcess ( lpApplicationname lpCommandLine lpProcessAttributes lpThreadAttributes bInheritHandles dwCreationFlags lpEnvironment lpCurrentDirectory lpStartupInfo lpProcessInformation -- BOOL ) CreateProcessW ;
! FUNCTION: CreateProcessInternalA
! FUNCTION: CreateProcessInternalW
! FUNCTION: CreateProcessInternalWSecure
! FUNCTION: DeleteFiber
! FUNCTION: DeleteFileA
FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
-: DeleteFile DeleteFileW ;
+: DeleteFile ( lpFileName -- BOOL ) DeleteFileW ;
! FUNCTION: DeleteTimerQueue
! FUNCTION: DeleteTimerQueueEx
! FUNCTION: DeleteTimerQueueTimer
FUNCTION: HANDLE FindFirstChangeNotificationW ( LPCTSTR lpPathName,
BOOL bWatchSubtree,
DWORD dwNotifyFilter ) ;
-: FindFirstChangeNotification FindFirstChangeNotificationW ;
+: FindFirstChangeNotification ( lpPathName bWatchSubtree dwNotifyFilter -- BOOL )
+ FindFirstChangeNotificationW ;
! FUNCTION: FindFirstFileA
! FUNCTION: FindFirstFileExA
! FUNCTION: FindFirstFileExW
FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFileData ) ;
-: FindFirstFile FindFirstFileW ;
+: FindFirstFile ( lpFileName lpFindFileData -- HANDLE ) FindFirstFileW ;
! FUNCTION: FindFirstVolumeA
! FUNCTION: FindFirstVolumeMountPointA
! FUNCTION: FindFirstVolumeMountPointW
FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ;
! FUNCTION: FindNextFileA
FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ;
-: FindNextFile FindNextFileW ;
+: FindNextFile ( hFindFile lpFindFileData -- BOOL ) FindNextFileW ;
! FUNCTION: FindNextVolumeA
! FUNCTION: FindNextVolumeMountPointA
! FUNCTION: FindNextVolumeMountPointW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
! FUNCTION: GetComputerNameExW
! FUNCTION: GetComputerNameW
-: GetComputerName GetComputerNameW ;
+: GetComputerName ( lpBuffer lpnSize -- BOOL ) GetComputerNameW ;
! FUNCTION: GetConsoleAliasA
! FUNCTION: GetConsoleAliasesA
! FUNCTION: GetConsoleAliasesLengthA
! FUNCTION: GetConsoleScreenBufferInfo
! FUNCTION: GetConsoleSelectionInfo
FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ;
-: GetConsoleTitle GetConsoleTitleW ; inline
+: GetConsoleTitle ( lpConsoleTitle nSize -- DWORD ) GetConsoleTitleW ; inline
! FUNCTION: GetConsoleWindow
! FUNCTION: GetCPFileNameFromRegistry
! FUNCTION: GetCPInfo
! FUNCTION: GetCurrentConsoleFont
! FUNCTION: GetCurrentDirectoryA
FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ;
-: GetCurrentDirectory GetCurrentDirectoryW ; inline
+: GetCurrentDirectory ( len buf -- BOOL ) GetCurrentDirectoryW ; inline
FUNCTION: HANDLE GetCurrentProcess ( ) ;
FUNCTION: DWORD GetCurrentProcessId ( ) ;
FUNCTION: HANDLE GetCurrentThread ( ) ;
FUNCTION: BOOL GetFileAttributesExW ( LPCTSTR lpFileName, GET_FILEEX_INFO_LEVELS fInfoLevelId, LPVOID lpFileInformation ) ;
-: GetFileAttributesEx GetFileAttributesExW ;
+: GetFileAttributesEx ( lpFileName fInfoLevelId lpFileInformation -- BOOL ) GetFileAttributesExW ;
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ;
! FUNCTION: GetFirmwareEnvironmentVariableW
! FUNCTION: GetFullPathNameA
FUNCTION: DWORD GetFullPathNameW ( LPCTSTR lpFileName, DWORD nBufferLength, LPTSTR lpBuffer, LPTSTR* lpFilePart ) ;
-: GetFullPathName GetFullPathNameW ;
+: GetFullPathName ( lpFileName nBufferLength lpBuffer lpFilePart -- DWORD ) GetFullPathNameW ;
! clear "license.txt" 32768 "char[32768]" <c-object> f over >r GetFullPathName r> swap 2 * head >string .
! FUNCTION: GetModuleFileNameA
! FUNCTION: GetModuleFileNameW
FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ;
-: GetModuleHandle GetModuleHandleW ; inline
+: GetModuleHandle ( lpModuleName -- HMODULE ) GetModuleHandleW ; inline
! FUNCTION: GetModuleHandleExA
! FUNCTION: GetModuleHandleExW
! FUNCTION: GetNamedPipeHandleStateA
! FUNCTION: GetSystemDefaultUILanguage
! FUNCTION: GetSystemDirectoryA
FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetSystemDirectory GetSystemDirectoryW ; inline
+: GetSystemDirectory ( lpBuffer uSize -- UINT ) GetSystemDirectoryW ; inline
FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ;
! FUNCTION: GetSystemPowerStatus
! FUNCTION: GetSystemRegistryQuota
! FUNCTION: GetSystemTimes
! FUNCTION: GetSystemWindowsDirectoryA
FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline
+: GetSystemWindowsDirectory ( lpBuffer uSize -- UINT ) GetSystemWindowsDirectoryW ; inline
! FUNCTION: GetSystemWow64DirectoryA
! FUNCTION: GetSystemWow64DirectoryW
! FUNCTION: GetTapeParameters
! FUNCTION: GetVDMCurrentDirectories
FUNCTION: DWORD GetVersion ( ) ;
FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
-: GetVersionEx GetVersionExW ;
+: GetVersionEx ( lpVersionInfo -- BOOL ) GetVersionExW ;
! FUNCTION: GetVolumeInformationA
! FUNCTION: GetVolumeInformationW
! FUNCTION: GetVolumeNameForVolumeMountPointA
! FUNCTION: GetVolumePathNameW
! FUNCTION: GetWindowsDirectoryA
FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetWindowsDirectory GetWindowsDirectoryW ; inline
+: GetWindowsDirectory ( lpBuffer uSize -- UINT ) GetWindowsDirectoryW ; inline
! FUNCTION: GetWriteWatch
! FUNCTION: GlobalAddAtomA
! FUNCTION: GlobalAddAtomW
! FUNCTION: MoveFileExA
! FUNCTION: MoveFileExW
FUNCTION: BOOL MoveFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName ) ;
-: MoveFile MoveFileW ;
+: MoveFile ( lpExistingFileName lpNewFileName -- BOOL ) MoveFileW ;
! FUNCTION: MoveFileWithProgressA
! FUNCTION: MoveFileWithProgressW
! FUNCTION: MulDiv
FUNCTION: HANDLE OpenFileMappingW ( DWORD dwDesiredAccess,
BOOL bInheritHandle,
LPCTSTR lpName ) ;
-: OpenFileMapping OpenFileMappingW ;
+: OpenFileMapping ( dwDesiredAccess bInheritHandle lpName -- HANDLE ) OpenFileMappingW ;
! FUNCTION: OpenJobObjectA
! FUNCTION: OpenJobObjectW
! FUNCTION: OpenMutexA
! FUNCTION: ReleaseSemaphore
! FUNCTION: RemoveDirectoryA
FUNCTION: BOOL RemoveDirectoryW ( LPCTSTR lpPathName ) ;
-: RemoveDirectory RemoveDirectoryW ;
+: RemoveDirectory ( lpPathName -- BOOL ) RemoveDirectoryW ;
! FUNCTION: RemoveLocalAlternateComputerNameA
! FUNCTION: RemoveLocalAlternateComputerNameW
! FUNCTION: RemoveVectoredExceptionHandler
! FUNCTION: SetConsoleScreenBufferSize
FUNCTION: BOOL SetConsoleTextAttribute ( HANDLE hConsoleOutput, WORD wAttributes ) ;
FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ;
-: SetConsoleTitle SetConsoleTitleW ;
+: SetConsoleTitle ( lpConsoleTitle -- BOOL ) SetConsoleTitleW ;
! FUNCTION: SetConsoleWindowInfo
! FUNCTION: SetCPGlobal
! FUNCTION: SetCriticalSectionSpinCount
! FUNCTION: SetCurrentDirectoryA
FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ;
-: SetCurrentDirectory SetCurrentDirectoryW ; inline
+: SetCurrentDirectory ( lpDirectory -- BOOL ) SetCurrentDirectoryW ; inline
! FUNCTION: SetDefaultCommConfigA
! FUNCTION: SetDefaultCommConfigW
! FUNCTION: SetDllDirectoryA
win32-error-string throw
] when ;
-: expected-io-errors
+: expected-io-errors ( -- seq )
ERROR_SUCCESS
ERROR_IO_INCOMPLETE
ERROR_IO_PENDING
! This code was based on by McCLIM's Backends/CLX/port.lisp
! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
-: XA_CLIPBOARD "CLIPBOARD" x-atom ;
+: XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
-: XA_UTF8_STRING "UTF8_STRING" x-atom ;
+: XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
TUPLE: x-clipboard atom contents ;
! with button names below.
-: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey
+: AnyModifier ( -- n ) 15 2^ ; ! used in GrabButton, GrabKey
! button names. Used as arguments to GrabButton and as detail in ButtonPress
! and ButtonRelease events. Not to be confused with button masks above.
! Used in SetInputFocus, GetInputFocus
-: RevertToNone None ;
-: RevertToPointerRoot PointerRoot ;
+: RevertToNone ( -- n ) None ;
+: RevertToPointerRoot ( -- n ) PointerRoot ;
: RevertToParent 2 ;
! *****************************************************************
! Flags used in StoreNamedColor, StoreColors
-: DoRed 1 0 shift ;
-: DoGreen 1 1 shift ;
-: DoBlue 1 2 shift ;
+: DoRed ( -- n ) 0 2^ ;
+: DoGreen ( -- n ) 1 2^ ;
+: DoBlue ( -- n ) 2 2^ ;
! *****************************************************************
! * CURSOR STUFF
! masks for ChangeKeyboardControl
-: KBKeyClickPercent 1 0 shift ;
-: KBBellPercent 1 1 shift ;
-: KBBellPitch 1 2 shift ;
-: KBBellDuration 1 3 shift ;
-: KBLed 1 4 shift ;
-: KBLedMode 1 5 shift ;
-: KBKey 1 6 shift ;
-: KBAutoRepeatMode 1 7 shift ;
+: KBKeyClickPercent ( -- n ) 0 2^ ;
+: KBBellPercent ( -- n ) 1 2^ ;
+: KBBellPitch ( -- n ) 2 2^ ;
+: KBBellDuration ( -- n ) 3 2^ ;
+: KBLed ( -- n ) 4 2^ ;
+: KBLedMode ( -- n ) 5 2^ ;
+: KBKey ( -- n ) 6 2^ ;
+: KBAutoRepeatMode ( -- n ) 7 2^ ;
: MappingSuccess 0 ;
: MappingBusy 1 ;
! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
-: USPosition 1 0 shift ; inline
-: USSize 1 1 shift ; inline
-: PPosition 1 2 shift ; inline
-: PSize 1 3 shift ; inline
-: PMinSize 1 4 shift ; inline
-: PMaxSize 1 5 shift ; inline
-: PResizeInc 1 6 shift ; inline
-: PAspect 1 7 shift ; inline
-: PBaseSize 1 8 shift ; inline
-: PWinGravity 1 9 shift ; inline
-: PAllHints
+: USPosition ( -- n ) 0 2^ ; inline
+: USSize ( -- n ) 1 2^ ; inline
+: PPosition ( -- n ) 2 2^ ; inline
+: PSize ( -- n ) 3 2^ ; inline
+: PMinSize ( -- n ) 4 2^ ; inline
+: PMaxSize ( -- n ) 5 2^ ; inline
+: PResizeInc ( -- n ) 6 2^ ; inline
+: PAspect ( -- n ) 7 2^ ; inline
+: PBaseSize ( -- n ) 8 2^ ; inline
+: PWinGravity ( -- n ) 9 2^ ; inline
+: PAllHints ( -- n )
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
C-STRUCT: XSizeHints
: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-: check-display
+: check-display ( alien -- alien' )
[
"Cannot connect to X server - check $DISPLAY" throw
] unless* ;
] with-string-writer ;
TUPLE: mismatched < parsing-error open close ;
-: <mismatched>
+: <mismatched> ( open close -- error )
\ mismatched parsing-error swap >>close swap >>open ;
M: mismatched summary ( obj -- str )
[
] with-string-writer ;
TUPLE: bad-version < parsing-error num ;
-: <bad-version>
+: <bad-version> ( num -- error )
\ bad-version parsing-error swap >>num ;
M: bad-version summary ( obj -- str )
[
-USING: kernel strings assocs sequences hashtables sorting
- unicode.case unicode.categories sets ;
+USING: accessors kernel strings assocs sequences hashtables
+sorting unicode.case unicode.categories sets ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap
H{ } clone { set-keyword-map-ignore-case? set-delegate }
keyword-map construct ;
-: invalid-no-word-sep f swap set-keyword-map-no-word-sep ;
+: invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ;
: handle-case ( key keyword-map -- key assoc )
[ keyword-map-ignore-case? [ >upper ] when ] keep
M: keyword-map >alist delegate >alist ;
-: (keyword-map-no-word-sep)
+: (keyword-map-no-word-sep) ( assoc -- str )
keys concat [ alpha? not ] filter prune natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str )
TAGS>
-: ?<regexp> dup [ ignore-case? get <regexp> ] when ;
+: ?<regexp> ( string/f -- regexp/f )
+ dup [ ignore-case? get <regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set>
[ string>token ]
} case ;
-: string>rule-set-name "MAIN" or ;
+: string>rule-set-name ( string -- name ) "MAIN" or ;
! PROP, PROPS
: parse-prop-tag ( tag -- key value )
dup children>string ignore-case? get <regexp>
swap position-attrs <matcher> ;
-: shared-tag-attrs
+: shared-tag-attrs ( -- )
{ "TYPE" string>token set-rule-body-token } , ; inline
-: delegate-attr
+: delegate-attr ( -- )
{ "DELEGATE" f set-rule-delegate } , ;
-: regexp-attr
+: regexp-attr ( -- )
{ "HASH_CHAR" f set-rule-chars } , ;
-: match-type-attr
+: match-type-attr ( -- )
{ "MATCH_TYPE" string>match-type set-rule-match-token } , ;
-: span-attrs
+: span-attrs ( -- )
{ "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
{ "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
{ "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
-: literal-start
+: literal-start ( -- )
[ parse-literal-matcher swap set-rule-start ] , ;
-: regexp-start
+: regexp-start ( -- )
[ parse-regexp-matcher swap set-rule-start ] , ;
-: literal-end
+: literal-end ( -- )
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
TAGS>
-: parse-begin/end-tags
+: parse-begin/end-tags ( -- )
[
! XXX: handle position attrs on span tag itself
child-tags [ parse-begin/end-tag ] with each
] , ;
-: init-span-tag [ drop init-span ] , ;
+: init-span-tag ( -- ) [ drop init-span ] , ;
-: init-eol-span-tag [ drop init-eol-span ] , ;
+: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
>r dup name-tag string>token swap children>string r> set-at ;
dup rule-body-token prev-token,
rule-match-token* next-token, ;
-: do-escaped
+: do-escaped ( -- )
escaped? get [
escaped? off
! ...
CREATE tag-handler-word set
H{ } clone tag-handlers set ; parsing
-: (TAG:) swap tag-handlers get set-at ;
+: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
f set-word
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
- define ; parsing
+ (( tag -- )) define-declared ; parsing
projects / factor.git / commitdiff