"FUNCTION: int do_foo ( int* a )"
}
"and writes to the pointer 'a', then it can be called like this:"
-{ $code
- "1234 int <ref> [ do_foo ] keep int deref"
+{ $code
+ "1234 int <ref> [ do_foo ] keep int deref"
}
"The stack will then contain the two integers emitted by the 'do_foo' function." ;
M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
M: enum-c-type c-type-setter
- [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
+ [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
: define-enum-value ( class value -- )
enum>number "enum-value" set-word-prop ;
<PRIVATE
: parse-ldconfig-lines ( string -- triple )
- [ ":-" split1 [ drop ] dip
- "=>" split1 [ [ unicode:blank? ] trim ] bi@
- 2array
- ] map ;
+ [
+ ":-" split1 [ drop ] dip
+ "=>" split1 [ [ unicode:blank? ] trim ] bi@
+ 2array
+ ] map ;
: load-ldconfig-cache ( -- seq )
"/sbin/ldconfig -r" utf8 [ read-lines ] with-process-reader
HELP: make-library
{ $values
- { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
- { "library" library } }
+ { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
+ { "library" library } }
{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
[ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
} cleave ;
M: enum-c-type-word definition
- lookup-c-type members>> ;
+ lookup-c-type members>> ;
jit-call-quot
vm-reg "end_callback" jit-call-1arg
- ] }
+ ] }
} define-sub-primitives
{ $description "Computes a time in the future that is the " { $snippet "duration" } " added to the result of " { $link now } "." }
{ $examples
{ $unchecked-example
- "USING: calendar prettyprint ;"
- "10 hours hence ."
- "T{ timestamp f 2008 9 2 2 47 45+943/1000 T{ duration f 0 0 0 -5 0 0 } }"
+ "USING: calendar prettyprint ;"
+ "10 hours hence ."
+ "T{ timestamp f 2008 9 2 2 47 45+943/1000 T{ duration f 0 0 0 -5 0 0 } }"
}
} ;
{ $description "Computes a time in the past that is the " { $snippet "duration" } " subtracted from the result of " { $link now } "." }
{ $examples
{ $unchecked-example
- "USING: calendar prettyprint ;"
- "3 weeks ago ."
- "T{ timestamp f 2008 8 11 16 49 52+99/500 T{ duration f 0 0 0 -5 0 0 } }"
+ "USING: calendar prettyprint ;"
+ "3 weeks ago ."
+ "T{ timestamp f 2008 8 11 16 49 52+99/500 T{ duration f 0 0 0 -5 0 0 } }"
}
} ;
HELP: since-1970
{ $values
- { "duration" duration }
- { "timestamp" timestamp } }
+ { "duration" duration }
+ { "timestamp" timestamp } }
{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
ARTICLE: "calendar" "Calendar"
[ day>> +day ]
[ month>> +month ]
[ year>> +year ]
- } cleave ; inline
+ } cleave ; inline
PRIVATE>
HELP: <circular-string>
{ $values
- { "n" integer }
- { "circular" circular } }
+ { "n" integer }
+ { "circular" circular } }
{ $description "Creates a new circular string object. A circular string is a string object that can be accessed out of bounds and the index will wrap around to the start of the string." } ;
HELP: <circular>
{ $values
- { "seq" sequence }
- { "circular" circular } }
+ { "seq" sequence }
+ { "circular" circular } }
{ $description "Creates a new " { $link circular } " object that wraps an existing sequence. By default, the index is set to zero." } ;
HELP: <growing-circular>
{ $values
- { "capacity" integer }
- { "growing-circular" growing-circular } }
+ { "capacity" integer }
+ { "growing-circular" growing-circular } }
{ $description "Creates a new growing-circular object." } ;
HELP: change-circular-start
{ $values
- { "n" integer } { "circular" circular } }
+ { "n" integer } { "circular" circular } }
{ $description "Changes the start index of a circular object." } ;
HELP: circular
HELP: circular-push
{ $values
- { "elt" object } { "circular" circular } }
+ { "elt" object } { "circular" circular } }
{ $description "Pushes an element to a " { $link circular } " object." } ;
HELP: growing-circular-push
{ $values
- { "elt" object } { "circular" circular } }
+ { "elt" object } { "circular" circular } }
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
HELP: rotate-circular
dup 1 -> setAllowsMultipleSelection: ;
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
- dup 1 -> setCanChooseDirectories: ;
+ dup 1 -> setCanChooseDirectories: ;
: <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel
HELP: &&
{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Each quotation must take the same number of arguments. Returns true if every quotation yields true, and stops early if one yields false." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
HELP: ||
{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Each quotation must take the same number of arguments. Returns true if any quotation yields true, and stops early when one yields true." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
144
} [
T{ stack-frame
- { params 91 }
- { allot-area-align 8 }
- { allot-area-size 10 }
- { spill-area-align 8 }
- { spill-area-size 16 }
+ { params 91 }
+ { allot-area-align 8 }
+ { allot-area-size 10 }
+ { spill-area-align 8 }
+ { spill-area-size 16 }
} finalize-stack-frame
slots[ allot-area-base spill-area-base total-size ]
! Exclude any reserved stack space 32 bytes on win64, 0 bytes
} apply-passes ;
: merge-set ( bbs -- bbs' )
- (merge-set) [ members ] dip nths ;
+ (merge-set) [ members ] dip nths ;
dup asset>> compiler-errors get-global set-at ;
T{ error-type-holder
- { type +compiler-error+ }
- { word ":errors" }
- { plural "compiler errors" }
- { icon "vocab:ui/tools/error-list/icons/compiler-error.png" }
- { quot [ compiler-errors get values ] }
- { forget-quot [ compiler-errors get delete-at ] }
+ { type +compiler-error+ }
+ { word ":errors" }
+ { plural "compiler errors" }
+ { icon "vocab:ui/tools/error-list/icons/compiler-error.png" }
+ { quot [ compiler-errors get values ] }
+ { forget-quot [ compiler-errors get delete-at ] }
} define-error-type
: <compiler-error> ( error word -- compiler-error )
'[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline
T{ error-type-holder
- { type +linkage-error+ }
- { word ":linkage" }
- { plural "linkage errors" }
- { icon "vocab:ui/tools/error-list/icons/linkage-error.png" }
- { quot [ linkage-errors get values ] }
- { forget-quot [ linkage-errors get delete-at ] }
- { fatal? f }
+ { type +linkage-error+ }
+ { word ":linkage" }
+ { plural "linkage errors" }
+ { icon "vocab:ui/tools/error-list/icons/linkage-error.png" }
+ { quot [ linkage-errors get values ] }
+ { forget-quot [ linkage-errors get delete-at ] }
+ { fatal? f }
} define-error-type
ERROR: no-such-library name message ;
] unit-test
{ 55 } [
- 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
+ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
] unit-test
: callback-17 ( -- callback )
! Reduction
: coalescing-bug-4 ( a b c -- a b c )
- [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
-
- [ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
- [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
- [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
- [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
- [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
- [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+ [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
+
+[ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
+[ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+[ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
+[ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
+[ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+[ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
! Global stack analysis dataflow equations are wrong
: some-word ( a -- b ) 2 + ;
] unit-test
[ B{ 0 1 2 3 4 } ] [
- 2 B{ 0 1 2 3 4 } <displaced-alien>
+ 2 B{ 0 1 2 3 4 } <displaced-alien>
[ 1 swap <displaced-alien> ] compile-call
underlying>>
] unit-test
255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255
255 255 0
}
- compress-dynamic gzip-inflate
+ compress-dynamic gzip-inflate
] unit-test
{ B{
255 255 255 0 255 255 255 0 255 255 255 0 255 255 255 0 255
255 255 0
}
- compress-fixed gzip-inflate
+ compress-fixed gzip-inflate
] unit-test
dup array? [ [ first 5 <bits> >bit-array reverse ] [ second ] bi 2array ] [ 5 <bits> >bit-array reverse ] if ;
: lit-to-bits ( lit -- bits )
- dup array? [ [ first (lit-to-bits) ] [ second ] bi 2array ] [ (lit-to-bits) ] if ;
+ dup array? [ [ first (lit-to-bits) ] [ second ] bi 2array ] [ (lit-to-bits) ] if ;
: pair-to-bits ( l,d -- bits )
[ first lit-to-bits ] [ second dist-to-bits ] bi 2array ;
! Use the given dictionary to replace the element with its code
:: replace-one ( ele code-dict -- new-ele )
- ele array? [ ele first code-dict at ele second 2array ] [ ele code-dict at ] if ;
+ ele array? [ ele first code-dict at ele second 2array ] [ ele code-dict at ] if ;
! replace both elements of a length distance pair with their codes
: replace-pair ( pair -- new-pair )
! Dictionary encoding
: lit-code-lens ( -- len-seq )
- 285 [0..b] [ lit-dict get at length ] map [ zero? ] trim-tail ;
+ 285 [0..b] [ lit-dict get at length ] map [ zero? ] trim-tail ;
: dist-code-lens ( -- len-seq )
- 31 [0..b] [ dist-dict get at length ] map [ zero? ] trim-tail ;
+ 31 [0..b] [ dist-dict get at length ] map [ zero? ] trim-tail ;
:: replace-0-single ( m len-seq -- new-len-seq )
m 11 < [ len-seq m 0 <array> 17 m 3 - 3 <bits> >bit-array 2array 1array replace ]
range empty? [ len-seq ] [ range first range 1 tail len-seq replace-all-runs replace-runs ] if ;
: run-free-lit ( -- len-seq )
- 0 285 [a..b] lit-code-lens replace-0 replace-all-runs ;
+ 0 285 [a..b] lit-code-lens replace-0 replace-all-runs ;
: run-free-dist ( -- len-seq )
0 31 [a..b] dist-code-lens replace-0 replace-all-runs ;
! Compresses a block with dynamic huffman compression, outputting a nested array structure
: (compress-dynamic) ( lit-seq -- bit-arr-seq )
- [ dup compress-lz77 vec-to-lits { 256 } append lit-vec set
+ [ dup compress-lz77 vec-to-lits { 256 } append lit-vec set
lit-vec get build-dicts
dist-dict set
lit-dict set
[ nip '[ _ swap _ set-at ] each ] 3bi ;
:: reverse-table ( tdesc n -- rtable )
- n f <array> <enumerated> :> table
- tdesc [ n table update-reverse-table ] huffman-each
- table seq>> ;
+
n f <array> <enumerated> :> table
+ tdesc [ n table update-reverse-table ] huffman-each
+ table seq>> ;
TUPLE: huffman-tree
{ code maybe{ fixnum } }
{ [ dup leaf? ] [ code>> ?{ } swap H{ } clone ?set-at ] }
{ [ dup left>> not ] [ right>> (generate-codes) [ ?{ t } prepend ] assoc-map ] }
{ [ dup right>> not ] [ left>> (generate-codes) [ ?{ f } prepend ] assoc-map ] }
- [
+ [
[ left>> (generate-codes) [ ?{ f } prepend ] assoc-map ]
[ right>> (generate-codes) [ ?{ t } prepend ] assoc-map ] bi assoc-union!
- ]
- } cond ;
+ ]
+ } cond ;
: generate-codes ( lit-seq -- code-dict )
[
- [ H{ } clone ]
- [ H{ } clone leaf-table set
+ [ H{ } clone ]
+ [ H{ } clone leaf-table set
<min-heap> node-heap set
build-tree heap-pop swap (generate-codes) nip ]
if-empty
>alist [ <==> ] sort ;
: get-next-code ( code current -- next )
- [ reverse bit-array>integer 1 + ] [ length ] bi <bits> >bit-array reverse dup length pick length swap - [ f ] replicate append nip ;
+ [ reverse bit-array>integer 1 + ] [ length ] bi <bits> >bit-array reverse dup length pick length swap - [ f ] replicate append nip ;
! Does most of the work of converting a collection of codes to canonical ones.
: (canonize-codes) ( current codes -- codes )
: read-until-terminated ( data -- data )
- [ dup 8 swap bs:read 0 = ] [ ] until ;
+ [ dup 8 swap bs:read 0 = ] [ ] until ;
:: interpret-flag ( flg data -- )
- 27 data bs:seek
- flg first 1 = [ 8 data bs:read data bs:seek ] when
- flg second 1 = [ data read-until-terminated drop ] when
- flg fourth 1 = [ data read-until-terminated drop ] when
- flg second 1 = [ 1 data bs:read drop ] when ;
+ 27 data bs:seek
+ flg first 1 = [ 8 data bs:read data bs:seek ] when
+ flg second 1 = [ data read-until-terminated drop ] when
+ flg fourth 1 = [ data read-until-terminated drop ] when
+ flg second 1 = [ 1 data bs:read drop ] when ;
:: check-gzip-header ( data -- )
8 data bs:read 31 assert= ! ID 1
<PRIVATE
: registered-remote-threads ( -- hash )
- \ registered-remote-threads get-global ;
+ \ registered-remote-threads get-global ;
: thread-connections ( -- hash )
\ thread-connections get-global ;
TUPLE: stock-spread stock spread timestamp ;
CONSTRUCTOR: <stock-spread> stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
+ now >>timestamp ;
SYMBOL: AAPL
: selection-rect ( dim line selection -- rect )
[let [ start>> ] [ end>> ] [ string>> ] tri :> ( start end string )
- start end [ 0 swap string subseq utf16n encode length 2 /i ] bi@
+ start end [ 0 swap string subseq utf16n encode length 2 /i ] bi@
]
[ f CTLineGetOffsetForStringIndex ] bi-curry@ bi
[ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;
[ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
: uuids-get ( server -- uuids )
- uuids-url couch-get "uuids" of >vector ;
+ uuids-url couch-get "uuids" of >vector ;
: get-uuids ( server -- server )
dup uuids-get [ nip ] curry change-uuids ;
{ CHAR: \r [ ] } ! Error: lf inside string?
[ [ , drop f maybe-escaped-quote ] when* ]
} case
- ] if ; inline recursive
+ ] if ; inline recursive
: quoted-field, ( delimiter stream -- delimiter stream sep/f )
"\"" over stream-read-until drop % t maybe-escaped-quote ;
! * use
!
FUNCTION: PGresult* PQfn ( PGconn* conn,
- int fnid,
- int* result_buf,
- int* result_len,
- int result_is_int,
- PQArgBlock* args,
- int nargs )
+ int fnid,
+ int* result_buf,
+ int* result_len,
+ int result_is_int,
+ PQArgBlock* args,
+ int nargs )
! Accessor functions for PGresult objects
FUNCTION: ExecStatusType PQresultStatus ( PGresult* res )
TUPLE: test-1 id a b c ;
test-1 "TEST1" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "a" "A" { VARCHAR 256 } +not-null+ }
- { "b" "B" { VARCHAR 256 } +not-null+ }
- { "c" "C" { VARCHAR 256 } +not-null+ }
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
} define-persistent
TUPLE: test-2 id x y z ;
test-2 "TEST2" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "x" "X" { VARCHAR 256 } +not-null+ }
- { "y" "Y" { VARCHAR 256 } +not-null+ }
- { "z" "Z" { VARCHAR 256 } +not-null+ }
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
: test-1-tuple ( -- tuple )
HELP: create-sql-statement
{ $values
- { "class" class }
- { "object" object } }
+ { "class" class }
+ { "object" object } }
{ $description "Generates the SQL code for creating a table for a given class." } ;
HELP: drop-sql-statement
{ $values
- { "class" class }
- { "object" object } }
+ { "class" class }
+ { "object" object } }
{ $description "Generates the SQL code for dropping a table for a given class." } ;
HELP: insert-tuple-set-key
{ $values
- { "tuple" tuple } { "statement" statement } }
+ { "tuple" tuple } { "statement" statement } }
{ $description "Inserts a tuple and sets its primary key in one word. This is necessary for some databases." } ;
HELP: <count-statement>
{ $values
- { "query" query }
- { "statement" statement } }
+ { "query" query }
+ { "statement" statement } }
{ $description "A database-specific hook for generating the SQL for a count statement." } ;
HELP: <delete-tuples-statement>
{ $values
- { "tuple" tuple } { "class" class }
- { "object" object } }
+ { "tuple" tuple } { "class" class }
+ { "object" object } }
{ $description "A database-specific hook for generating the SQL for an delete statement." } ;
HELP: <insert-db-assigned-statement>
{ $values
- { "class" class }
- { "object" object } }
+ { "class" class }
+ { "object" object } }
{ $description "A database-specific hook for generating the SQL for an insert statement with a database-assigned primary key." } ;
HELP: <insert-user-assigned-statement>
{ $values
- { "class" class }
- { "object" object } }
+ { "class" class }
+ { "object" object } }
{ $description "A database-specific hook for generating the SQL for an insert statement with a user-assigned primary key." } ;
HELP: <select-by-slots-statement>
{ $values
- { "tuple" tuple } { "class" class }
- { "statement" tuple } }
+ { "tuple" tuple } { "class" class }
+ { "statement" tuple } }
{ $description "A database-specific hook for generating the SQL for a select statement." } ;
HELP: <update-tuple-statement>
{ $values
- { "class" class }
- { "object" object } }
+ { "class" class }
+ { "object" object } }
{ $description "A database-specific hook for generating the SQL for an update statement." } ;
HELP: define-persistent
{ $values
- { "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
+ { "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to an SQL database table name. The format for the slot specifiers is as follows:"
{ $list
{ "a slot name from the " { $snippet "tuple class" } }
HELP: create-table
{ $values
- { "class" class } }
+ { "class" class } }
{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
HELP: ensure-table
{ $values
- { "class" class } }
+ { "class" class } }
{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
HELP: ensure-tables
{ $values
- { "classes" "a sequence of classes" } }
+ { "classes" "a sequence of classes" } }
{ $description "Creates an SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
HELP: recreate-table
{ $values
- { "class" class } }
+ { "class" class } }
{ $description "Drops an existing table and re-creates it from a mapping defined by " { $link define-persistent } ". If the table does not exist the error is silently ignored." }
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } $nl
" Use " { $link ensure-table } " unless you want to delete the data in this table." } ;
HELP: drop-table
{ $values
- { "class" class } }
+ { "class" class } }
{ $description "Drops an existing table which deletes all of the data. The database will probably throw an error if the table does not exist." }
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } } ;
HELP: insert-tuple
{ $values
- { "tuple" tuple } }
+ { "tuple" tuple } }
{ $description "Inserts a tuple into a database if a relation has been defined with " { $link define-persistent } ". If a mapping states that the database assigns a primary key to the tuple, this value will be set after this word runs." }
{ $notes "Objects should only be inserted into a database once per object. To store the object after the initial insert, call " { $link update-tuple } "." } ;
HELP: update-tuple
{ $values
- { "tuple" tuple } }
+ { "tuple" tuple } }
{ $description "Updates a tuple that has already been inserted into a database. The tuple must have a primary key that has been set by " { $link insert-tuple } " or that is user-defined." } ;
HELP: update-tuples
{ $values
- { "query/tuple" tuple }
- { "quot" { $quotation ( tuple -- tuple'/f ) } } }
+ { "query/tuple" tuple }
+ { "quot" { $quotation ( tuple -- tuple'/f ) } } }
{ $description "An SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". The " { $snippet "quot" } " is applied to each tuple from the database that matches the query, and the changed tuple is stored back to the database. If the " { $snippet "quot" } " returns " { $link f } ", the tuple is dropped, and its data remains unmodified in the database."
$nl
"The word is equivalent to the following code:"
HELP: delete-tuples
{ $values
- { "tuple" tuple } }
+ { "tuple" tuple } }
{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate an SQL statement that deletes tuples." }
{ $warning "This word will delete your data." } ;
HELP: reject-tuples
{ $values
- { "query/tuple" tuple }
- { "quot" { $quotation ( tuple -- ? ) } } }
+ { "query/tuple" tuple }
+ { "quot" { $quotation ( tuple -- ? ) } } }
{ $description "An SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". The " { $snippet "quot" } " is applied to each tuple from the database that matches the query, and if it returns a true value, the row is deleted from the database."
$nl
"The word is equivalent to the following code:"
HELP: each-tuple
{ $values
- { "query/tuple" tuple }
- { "quot" { $quotation ( tuple -- ) } } }
+ { "query/tuple" tuple }
+ { "quot" { $quotation ( tuple -- ) } } }
{ $description "An SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". The " { $snippet "quot" } " is applied to each tuple from the database that matches the query constructed from the exemplar tuple." } ;
HELP: select-tuple
{ $values
- { "query/tuple" tuple }
- { "tuple/f" { $maybe tuple } } }
+ { "query/tuple" tuple }
+ { "tuple/f" { $maybe tuple } } }
{ $description "An SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
HELP: select-tuples
{ $values
- { "query/tuple" tuple }
- { "tuples" "an array of tuples" } }
+ { "query/tuple" tuple }
+ { "tuples" "an array of tuples" } }
{ $description "An SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns an array of multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
HELP: count-tuples
{ $values
- { "query/tuple" tuple }
- { "n" integer } }
+ { "query/tuple" tuple }
+ { "n" integer } }
{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
{ each-tuple select-tuple select-tuples count-tuples } related-words
"Now we've created a book. Let's save it to the database."
{ $code "USING: db db.sqlite fry io.files.temp ;
: with-book-tutorial ( quot -- )
- '[ \"book-tutorial.db\" temp-file <sqlite-db> _ with-db ] call ; inline
+ '[ \"book-tutorial.db\" temp-file <sqlite-db> _ with-db ] call ; inline
[
book recreate-table
HELP: user-assigned-id-spec?
{ $values
- { "specs" "a sequence of SQL specs" }
- { "?" boolean } }
+ { "specs" "a sequence of SQL specs" }
+ { "?" boolean } }
{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
HELP: bind#
{ $values
- { "spec" "an SQL spec" } { "obj" object } }
+ { "spec" "an SQL spec" } { "obj" object } }
{ $description "A generic word that lets a database construct a literal binding." } ;
HELP: bind%
{ $values
- { "spec" "an SQL spec" } }
+ { "spec" "an SQL spec" } }
{ $description "A generic word that lets a database output a binding." } ;
HELP: db-assigned-id-spec?
{ $values
- { "specs" "a sequence of SQL specs" }
- { "?" boolean } }
+ { "specs" "a sequence of SQL specs" }
+ { "?" boolean } }
{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
HELP: find-primary-key
{ $values
- { "specs" "a sequence of SQL specs" }
- { "seq" "a sequence of SQL specs" } }
+ { "specs" "a sequence of SQL specs" }
+ { "seq" "a sequence of SQL specs" } }
{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ $notes "This is a low-level word." } ;
HELP: no-sql-type
{ $values
- { "type" "an SQL type" } }
+ { "type" "an SQL type" } }
{ $description "Throws an error containing an SQL type that is unsupported or the result of a typo." } ;
HELP: normalize-spec
{ $values
- { "spec" "an SQL spec" } }
+ { "spec" "an SQL spec" } }
{ $description "Normalizes an SQL spec." } ;
HELP: primary-key?
{ $values
- { "spec" "an SQL spec" }
- { "?" boolean } }
+ { "spec" "an SQL spec" }
+ { "?" boolean } }
{ $description "Returns true if an SQL spec is a primary key." } ;
HELP: relation?
{ $values
- { "spec" "an SQL spec" }
- { "?" boolean } }
+ { "spec" "an SQL spec" }
+ { "?" boolean } }
{ $description "Returns true if an SQL spec is a relation." } ;
HELP: unknown-modifier
HELP: clear-deque
{ $values
- { "deque" deque } }
+ { "deque" deque } }
{ $description "Removes all elements from a deque." } ;
HELP: deque-member?
{ $values
- { "value" object } { "deque" deque }
- { "?" boolean } }
+ { "value" object } { "deque" deque }
+ { "?" boolean } }
{ $description "Returns true if the " { $snippet "value" } " is found in the deque." } ;
HELP: push-front
HELP: push-all-back
{ $values
- { "seq" sequence } { "deque" deque } }
+ { "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the back of a deque." } ;
HELP: push-all-front
{ $values
- { "seq" sequence } { "deque" deque } }
+ { "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the front of a deque." } ;
HELP: peek-front*
HELP: delete-node
{ $values
- { "node" object } { "deque" deque } }
+ { "node" object } { "deque" deque } }
{ $contract "Deletes the node from the deque." } ;
HELP: deque
HELP: node-value
{ $values
- { "node" object }
- { "value" object } }
+ { "node" object }
+ { "value" object } }
{ $description "Accesses the value stored at a node." } ;
HELP: slurp-deque
{ $values
- { "deque" deque } { "quot" { $quotation ( ... obj -- ... ) } } }
+ { "deque" deque } { "quot" { $quotation ( ... obj -- ... ) } } }
{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." }
{ $examples
{ $example
"The " { $link plan9-path } " word will try to locate your Plan9"
" installation. In order of preference this word checks:"
$nl
-{
- $list
- { "The " { $link plan9-path } " global" }
- "The PLAN9 environment variable"
+{ $list
+ { "The " { $link plan9-path } " global" }
+ "The PLAN9 environment variable"
}
$nl
"Finally, if neither is available, falls back to "
: (massage-pathname) ( file line -- str )
over file-info regular-file?
- [ number>string 2array ":" join ]
- [ drop ] if ;
+ [ number>string 2array ":" join ]
+ [ drop ] if ;
PRIVATE>
M: acme editor-command ( file line -- command )
- [ (plumb-path) , "-d" , "edit" , (massage-pathname) , ] { } make ;
+ [ (plumb-path) , "-d" , "edit" , (massage-pathname) , ] { } make ;
HELP: (os-envs)
{ $values
-
- { "seq" sequence } }
+ { "seq" sequence } }
{ $description "Returns a sequence of key/value pairs from the operating system." }
{ $notes "In most cases, use " { $link os-envs } " instead." } ;
HELP: (set-os-envs)
{ $values
- { "seq" sequence } }
+ { "seq" sequence } }
{ $description "Low-level word for replacing the current set of environment variables." }
{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
{ "<p>asdf</p><ul><li>lol</li><li>haha</li></ul>" } [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
{ "<p>asdf</p><ul><li>lol</li><li>haha</li></ul>" }
- [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
+[ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
{ "<hr/>" } [ "___" convert-farkup ] unit-test
{ "<hr/>" } [ "___\n" convert-farkup ] unit-test
HELP: font-with-background
{ $values
- { "font" font } { "color" color }
- { "font'" font }
+ { "font" font } { "color" color }
+ { "font'" font }
}
{ $description "Creates a new font equal to the given font, except with a different " { $slot "background" } " slot." } ;
HELP: font-with-foreground
{ $values
- { "font" font } { "color" color }
- { "font'" font }
+ { "font" font } { "color" color }
+ { "font'" font }
}
{ $description "Creates a new font equal to the given font, except with a different " { $slot "foreground" } " slot." } ;
: >datetime ( timestamp -- string )
[
{
- [ day-of-week day-abbreviation3 ]
- [ month>> month-abbreviation ]
- [ day>> pad-00 ]
- [ >time ]
- [ year>> number>string ]
+ [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> pad-00 ]
+ [ >time ]
+ [ year>> number>string ]
} cleave
] output>array join-words ; inline
HELP: <chloe-content>
{ $values
- { "path" "a path" }
- { "response" response }
+ { "path" "a path" }
+ { "response" response }
}
{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
HELP: new-action
{ $values
- { "class" class }
- { "action" action }
+ { "class" class }
+ { "action" action }
}
{ $description "Constructs a subclass of " { $link action } "." } ;
HELP: validate-params
{ $values
- { "validators" "an association list mapping parameter names to validator quotations" }
+ { "validators" "an association list mapping parameter names to validator quotations" }
}
{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." }
{ $examples
HELP: <protected>
{ $values
- { "responder" "a responder" }
- { "protected" "a new responder" }
+ { "responder" "a responder" }
+ { "protected" "a new responder" }
}
{ $description "Wraps a responder in a protected responder. Access to the wrapped responder will be conditional upon the client authenticating with the current authentication realm." } ;
HELP: encode-password
{ $values
- { "string" string } { "salt" integer }
- { "bytes" byte-array }
+ { "string" string } { "salt" integer }
+ { "bytes" byte-array }
}
{ $description "Encodes a password with the current authentication realm's checksum." } ;
HELP: have-capabilities?
{ $values
- { "capabilities" "a sequence of capabilities" }
- { "?" boolean }
+ { "capabilities" "a sequence of capabilities" }
+ { "?" boolean }
}
{ $description "Tests if the currently logged-in user possesses the given capabilities." } ;
HELP: login-required
{ $values
- { "description" string } { "capabilities" "a sequence of capabilities" }
+ { "description" string } { "capabilities" "a sequence of capabilities" }
}
{ $description "Redirects the client to a login page." } ;
HELP: login-required*
{ $values
- { "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" }
- { "response" response }
+ { "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" }
+ { "response" response }
}
{ $contract "Constructs an HTTP response for redirecting the client to a login page." } ;
HELP: <login-realm>
{ $values
- { "responder" "a responder" } { "name" string }
- { "realm" "a new responder" }
+ { "responder" "a responder" } { "name" string }
+ { "realm" "a new responder" }
}
{ $description "Wraps a responder in a new login realm with the given name. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ;
bi ;
: user>user-hash ( user -- hash )
- hash-mirror
- [ [ "password" ] dip [ >base64 >string ] change-at ] keep
- couchdb-auth-provider get field-map>> map-fields-forward ;
+ hash-mirror
+ [ [ "password" ] dip [ >base64 >string ] change-at ] keep
+ couchdb-auth-provider get field-map>> map-fields-forward ;
! Used when the user is guaranteed to exist if the logic of the Factor
! code is correct (e.g. when update-user is called).
HELP: <boilerplate>
{ $values
- { "responder" "a responder" }
- { "boilerplate" "a new boilerplate responder" }
+ { "responder" "a responder" }
+ { "boilerplate" "a new boilerplate responder" }
}
{ $description "Wraps a responder in a boilerplate responder. The boilerplate responder needs to be configured before use; see " { $link "furnace.boilerplate.config" } "." } ;
HELP: <conversations>
{ $values
- { "responder" "a responder" }
- { "responder'" "a new responder" }
+ { "responder" "a responder" }
+ { "responder'" "a new responder" }
}
{ $description "Creates a new " { $link conversations } " responder wrapping an existing responder." } ;
HELP: <db-persistence>
{ $values
- { "responder" "a responder" } { "db" "a database descriptor" }
- { "responder'" db-persistence }
+ { "responder" "a responder" } { "db" "a database descriptor" }
+ { "responder'" db-persistence }
}
{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
HELP: <secure-redirect>
{ $values
- { "url" url }
- { "response" response }
+ { "url" url }
+ { "response" response }
}
{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." }
{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ;
HELP: >secure-url
{ $values
- { "url" url }
- { "url'" url }
+ { "url" url }
+ { "url'" url }
}
{ $description "Sets the protocol of a URL to HTTPS." } ;
HELP: if-secure
{ $values
- { "quot" quotation }
- { "response" response }
+ { "quot" quotation }
+ { "response" response }
}
{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ;
HELP: <check-form-submissions>
{ $values
- { "responder" "a responder" }
- { "responder'" "a responder" }
+ { "responder" "a responder" }
+ { "responder'" "a responder" }
}
{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ;
HELP: <sessions>
{ $values
- { "responder" "a responder" }
- { "responder'" "a new responder" }
+ { "responder" "a responder" }
+ { "responder'" "a new responder" }
}
{ $description "Wraps a responder in a session manager responder." } ;
HELP: >entry
{ $values
- { "object" object }
- { "entry" entry }
+ { "object" object }
+ { "entry" entry }
}
{ $contract "Converts an object into an Atom feed entry. The default implementation constructs an entry by calling "
{ $link feed-entry-title } ", "
HELP: feed-entry-date
{ $values
- { "object" object }
- { "timestamp" timestamp }
+ { "object" object }
+ { "timestamp" timestamp }
}
{ $contract "Outputs a feed entry timestmap." } ;
HELP: feed-entry-description
{ $values
- { "object" object }
- { "description" string }
+ { "object" object }
+ { "description" string }
}
{ $contract "Outputs a feed entry description." } ;
HELP: feed-entry-title
{ $values
- { "object" object }
- { "string" string }
+ { "object" object }
+ { "string" string }
}
{ $contract "Outputs a feed entry title." } ;
HELP: feed-entry-url
{ $values
- { "object" object }
- { "url" url }
+ { "object" object }
+ { "url" url }
}
{ $contract "Outputs a feed entry URL." } ;
map-index-compose 2cleave ;
: >pov ( byte -- symbol )
- {
+ {
pov-neutral
pov-up
pov-down
pov-neutral
pov-neutral
pov-neutral
- } nth ;
+ } nth ;
: fill-controller-state ( XINPUT_STATE -- controller-state )
Gamepad>> controller-state new dup rot
}
});
</script>
- XML] ;
+ XML] ;
: help-header ( stylesheet -- xml )
help-stylesheet help-meta swap help-script 3append ;
<a href="/">Handbook</a>
<a href=<->>Glossary</a>
</nav>
- XML] ;
+ XML] ;
: help-footer ( -- xml )
version-info "\n" split1 drop
] vocabs-quot get call( quot -- )
] leaks members no-ui-disposables
dup length 0 > [
- dup [ class-of ] histogram-by
- [ "Leaked resources: " write ... ] with-string-writer simple-lint-error
+ dup [ class-of ] histogram-by
+ [ "Leaked resources: " write ... ] with-string-writer simple-lint-error
] [
drop
] if ;
SYMBOL: +help-lint-failure+
T{ error-type-holder
- { type +help-lint-failure+ }
- { word ":lint-failures" }
- { plural "help lint failures" }
- { icon "vocab:ui/tools/error-list/icons/help-lint-error.png" }
- { quot [ lint-failures get values ] }
- { forget-quot [ lint-failures get delete-at ] }
+ { type +help-lint-failure+ }
+ { word ":lint-failures" }
+ { plural "help lint failures" }
+ { icon "vocab:ui/tools/error-list/icons/help-lint-error.png" }
+ { quot [ lint-failures get values ] }
+ { forget-quot [ lint-failures get delete-at ] }
} define-error-type
M: help-lint-error error-type drop +help-lint-failure+ ;
print-element $snippet ;
: ($instances) ( element -- )
- dup word? [ ($link) "s" print-element ] [ print-element ] if ;
+ dup word? [ ($link) "s" print-element ] [ print-element ] if ;
: $sequence ( element -- )
{ "a " { $link sequence } " of " } print-element
"https://www.apple.com/index.html"
"CONNECT" <client-request>
f >>proxy-url
- request-uri
+ request-uri
] unit-test
{ f } [
! This url is misparsed bu request-url can fix it
{ T{ url
- { protocol "http" }
- { host "www.google.com" }
- { path "/" }
- { port 80 }
+ { protocol "http" }
+ { host "www.google.com" }
+ { path "/" }
+ { port 80 }
} } [ "www.google.com" request-url ] unit-test
! This one is not fixable, leave it as it is
: no-proxy? ( request -- ? )
get-no-proxy-list [
- [ url>> host>> "." split ] dip "," split
- [ "." split no-proxy-match? ] with any?
+ [ url>> host>> "." split ] dip "," split
+ [ "." split no-proxy-match? ] with any?
] [ drop f ] if* ;
: (check-proxy) ( proxy -- ? )
HELP: add-responder
{ $values
- { "dispatcher" dispatcher } { "responder" "a responder" } { "path" "a pathname string or hostname" } }
+ { "dispatcher" dispatcher } { "responder" "a responder" } { "path" "a pathname string or hostname" } }
{ $description "Adds a responder to a dispatcher." }
{ $notes "The " { $snippet "path" } " parameter is interpreted differently depending on the dispatcher type." }
{ $side-effects "dispatcher" } ;
HELP: call-responder
{ $values
- { "path" "a sequence of strings" } { "responder" "a responder" }
- { "response" response } }
+ { "path" "a sequence of strings" } { "responder" "a responder" }
+ { "response" response } }
{ $description "Calls a responder." } ;
HELP: call-responder*
{ $values
- { "path" "a sequence of strings" } { "responder" "a responder" }
- { "response" response } }
+ { "path" "a sequence of strings" } { "responder" "a responder" }
+ { "response" response } }
{ $contract "Processes an HTTP request and returns a response." }
{ $notes "When this word is called, various dynamic variables are set; see " { $link "http.server.requests" } "." } ;
HELP: param
{ $values
- { "name" string }
- { "value" string }
+ { "name" string }
+ { "value" string }
}
{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
HELP: <static>
{ $values
- { "root" "a pathname string" }
- { "responder" file-responder } }
- { $description "Creates a file responder which serves content from " { $snippet "path" } "." } ;
+ { "root" "a pathname string" }
+ { "responder" file-responder } }
+{ $description "Creates a file responder which serves content from " { $snippet "path" } "." } ;
HELP: enable-fhtml
{ $values { "responder" file-responder } }
{ "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" "webp" }
] [
supported-ns-image-extensions
- ] if [ ns-image register-image-class ] each
+ ] if [ ns-image register-image-class ] each
] when
: <CGImage> ( byte-array -- image-rep )
{ H{ { "owner" H{ { "name" "John Doe" }
{ "organization" "Acme Widgets Inc." } } }
- { "database" H{ { "server" "192.0.2.62" }
+ { "database" H{ { "server" "192.0.2.62" }
{ "port" "143" }
{ "file" "payroll.dat" } } } } }
[
HELP: add-file-permissions
{ $values
- { "path" "a pathname string" }
- { "n" integer } }
+ { "path" "a pathname string" }
+ { "n" integer } }
{ $description "Ensures that the bits from " { $snippet "n" } " are set in the Unix file permissions for a given file." } ;
HELP: remove-file-permissions
{ $values
- { "path" "a pathname string" }
- { "n" integer } }
+ { "path" "a pathname string" }
+ { "n" integer } }
{ $description "Ensures that the bits from " { $snippet "n" } " are cleared in the Unix file permissions for a given file." } ;
HELP: file-group-id
{ $values
- { "path" "a pathname string" }
- { "gid" integer } }
+ { "path" "a pathname string" }
+ { "gid" integer } }
{ $description "Returns the group id for a given file." } ;
HELP: file-group-name
{ $values
- { "path" "a pathname string" }
- { "string" string } }
+ { "path" "a pathname string" }
+ { "string" string } }
{ $description "Returns the group name for a given file." } ;
HELP: file-permissions
{ $values
- { "path" "a pathname string" }
- { "n" integer } }
+ { "path" "a pathname string" }
+ { "n" integer } }
{ $description "Returns the Unix file permissions for a given file." } ;
HELP: file-user-name
{ $values
- { "path" "a pathname string" }
- { "string" string } }
+ { "path" "a pathname string" }
+ { "string" string } }
{ $description "Returns the user-name for a given file." } ;
HELP: file-user-id
{ $values
- { "path" "a pathname string" }
- { "uid" integer } }
+ { "path" "a pathname string" }
+ { "uid" integer } }
{ $description "Returns the user id for a given file." } ;
HELP: group-execute?
{ $values
- { "obj" "a pathname string or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-read?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-write?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-execute?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-read?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-write?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-file-access-time
{ $values
- { "path" "a pathname string" } { "timestamp" timestamp } }
+ { "path" "a pathname string" } { "timestamp" timestamp } }
{ $description "Sets a file's last access timestamp." } ;
HELP: set-file-group
{ $values
- { "path" "a pathname string" } { "string/id" "a string or a group id" } }
+ { "path" "a pathname string" } { "string/id" "a string or a group id" } }
{ $description "Sets a file's group id from the given group id or group name." } ;
HELP: set-file-ids
{ $values
- { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
+ { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
{ $description "Sets the user id and group id of a file with a single library call." } ;
HELP: set-file-permissions
{ $values
- { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
+ { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer." }
{ $examples "Using the traditional octal value:"
{ $code "USING: io.files.info.unix kernel ;"
HELP: set-file-times
{ $values
- { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
+ { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ;
HELP: set-file-user
{ $values
- { "path" "a pathname string" } { "string/id" "a string or a user id" } }
+ { "path" "a pathname string" } { "string/id" "a string or a user id" } }
{ $description "Sets a file's user id from the given user id or user-name." } ;
HELP: set-file-modified-time
{ $values
- { "path" "a pathname string" } { "timestamp" timestamp } }
+ { "path" "a pathname string" } { "timestamp" timestamp } }
{ $description "Sets a file's last modified timestamp, or write timestamp." } ;
HELP: set-gid
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ;
HELP: gid?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-group-execute
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ;
HELP: set-group-read
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ;
HELP: set-group-write
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ;
HELP: set-other-execute
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
HELP: set-other-read
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ;
HELP: set-other-write
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
HELP: set-sticky
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ;
HELP: sticky?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-uid
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ;
HELP: uid?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-user-execute
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ;
HELP: set-user-read
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ;
HELP: set-user-write
{ $values
- { "path" "a pathname string" } { "?" boolean } }
+ { "path" "a pathname string" } { "?" boolean } }
{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ;
HELP: user-execute?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-read?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-write?
{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" boolean } }
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" boolean } }
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
ARTICLE: "unix-file-permissions" "Unix file permissions"
HELP: follow-link
{ $values
- { "path" "a pathname string" }
- { "path'" "a pathname string" }
+ { "path" "a pathname string" }
+ { "path'" "a pathname string" }
}
{ $description "Returns an absolute path from " { $link read-link } "." } ;
HELP: follow-links
{ $values
- { "path" "a pathname string" }
- { "path'" "a pathname string" }
+ { "path" "a pathname string" }
+ { "path'" "a pathname string" }
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
HELP: symlink-depth
{ $values
- { "value" integer }
+ { "value" integer }
}
{ $description "The number of redirections " { $link follow-links } " will follow." } ;
HELP: too-many-symlinks
{ $values
- { "path" "a pathname string" } { "n" integer }
+ { "path" "a pathname string" } { "n" integer }
}
{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
C: <io-callback> io-callback
: <completion-port> ( handle existing -- handle )
- f 1 CreateIoCompletionPort dup win32-error=0/f ;
+ f 1 CreateIoCompletionPort dup win32-error=0/f ;
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer }
- { "stream'" "an input stream" }
+ { "stream" "an input stream" } { "limit" integer }
+ { "stream'" "an input stream" }
}
{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit-stream } " or " { $link limited-input } "." } ;
HELP: limit-stream
{ $values
- { "stream" "an input stream" } { "limit" integer }
- { "stream'" "a stream" }
+ { "stream" "an input stream" } { "limit" integer }
+ { "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
{ $examples
[ not-a-json-number? ] must-fail-with
! unclosed objects and mismatched brackets are not allowed
- [ "[\"a\",
+[ "[\"a\",
4
,1," json> ] must-fail
$nl
"Some options can control the formatting of the result:"
{ $table
- { { $link json-allow-fp-special? } "Allow special floating-points: NaN, Infinity, -Infinity" }
- { { $link json-friendly-keys? } "Convert - to _ in tuple slots and hashtable keys" }
- { { $link json-coerce-keys? } "Coerce hashtable keys into strings" }
- { { $link json-escape-slashes? } "Escape forward slashes inside strings" }
- { { $link json-escape-unicode? } "Escape unicode values inside strings" }
+ { { $link json-allow-fp-special? } "Allow special floating-points: NaN, Infinity, -Infinity" }
+ { { $link json-friendly-keys? } "Convert - to _ in tuple slots and hashtable keys" }
+ { { $link json-coerce-keys? } "Coerce hashtable keys into strings" }
+ { { $link json-escape-slashes? } "Escape forward slashes inside strings" }
+ { { $link json-escape-unicode? } "Escape unicode values inside strings" }
}
}
{ $see-also >json } ;
[ list1>> cdr ] [ list2>> ] bi lappend-lazy ;
M: lazy-append nil?
- drop f ;
+ drop f ;
TUPLE: lazy-from-by n quot ;
] unit-test
{ 15 } [
- { 1 2 3 4 5 } sequence>list 0 [ + ] foldr
+ { 1 2 3 4 5 } sequence>list 0 [ + ] foldr
] unit-test
{ { 5 4 3 2 1 } } [
HELP: bit-count
{ $values
- { "obj" object }
- { "n" integer }
+ { "obj" object }
+ { "n" integer }
}
{ $description "Returns the number of set bits as an object. This word only works on non-negative integers or objects that can be represented as a byte-array." }
{ $examples
HELP: bitroll-32
{ $values
- { "m" integer } { "s" integer }
- { "n" integer }
+ { "m" integer } { "s" integer }
+ { "n" integer }
}
{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
{ $examples
HELP: bitroll-64
{ $values
- { "m" integer } { "s" "a shift integer" }
- { "n" integer }
+ { "m" integer } { "s" "a shift integer" }
+ { "n" integer }
}
{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
{ $examples
HELP: clear-bit
{ $values
- { "x" integer } { "n" integer }
- { "y" integer }
+ { "x" integer } { "n" integer }
+ { "y" integer }
}
{ $description "Sets the " { $snippet "n" } "th bit of " { $snippet "x" } " to zero." }
{ $examples
HELP: mask
{ $values
- { "x" integer } { "n" integer }
- { "y" integer }
+ { "x" integer } { "n" integer }
+ { "y" integer }
}
{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
{ $examples
HELP: mask-bit
{ $values
- { "m" integer } { "n" integer }
- { "m'" integer }
+ { "m" integer } { "n" integer }
+ { "m'" integer }
}
{ $description "Turns off all bits besides the " { $snippet "n" } "th bit." }
{ $examples
HELP: mask?
{ $values
- { "x" integer } { "n" integer }
- { "?" boolean }
+ { "x" integer } { "n" integer }
+ { "?" boolean }
}
{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
{ $examples
HELP: on-bits
{ $values
- { "m" integer }
- { "n" integer }
+ { "m" integer }
+ { "n" integer }
}
{ $description "Returns an integer with " { $snippet "m" } " bits set." }
{ $examples
HELP: toggle-bit
{ $values
- { "m" integer }
- { "n" integer }
- { "m'" integer }
+ { "m" integer }
+ { "n" integer }
+ { "m'" integer }
}
{ $description "Toggles the " { $snippet "n" } "th bit of an integer." }
{ $examples
HELP: set-bit
{ $values
- { "x" integer } { "n" integer }
- { "y" integer }
+ { "x" integer } { "n" integer }
+ { "y" integer }
}
{ $description "Sets the " { $snippet "n" } "th bit of " { $snippet "x" } "." }
{ $examples
HELP: shift-mod
{ $values
- { "m" integer } { "s" integer } { "w" integer }
- { "n" integer }
+ { "m" integer } { "s" integer } { "w" integer }
+ { "n" integer }
}
{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: unmask
{ $values
- { "x" integer } { "n" integer }
- { "y" integer }
+ { "x" integer } { "n" integer }
+ { "y" integer }
}
{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
{ $examples
HELP: unmask?
{ $values
- { "x" integer } { "n" integer }
- { "?" boolean }
+ { "x" integer } { "n" integer }
+ { "?" boolean }
}
{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
{ $examples
HELP: w*
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Multiplies two integers and wraps the result to a 32-bit unsigned integer." }
{ $examples
HELP: w+
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Adds two integers and wraps the result to a 32-bit unsigned integer." }
{ $examples
HELP: w-
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Subtracts two integers and wraps the result to a 32-bit unsigned integer." }
{ $examples
HELP: W*
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Multiplies two integers and wraps the result to a 64-bit unsigned integer." }
{ $examples
HELP: W+
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Adds two integers and wraps the result to 64-bit unsigned integer." }
{ $examples
HELP: W-
{ $values
- { "x" integer } { "y" integer }
- { "z" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Subtracts two integers and wraps the result to a 64-bit unsigned integer." }
{ $examples
HELP: wrap
{ $values
- { "m" integer } { "n" integer }
- { "m'" integer }
+ { "m" integer } { "n" integer }
+ { "m'" integer }
}
{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
{ $examples "Equivalent to modding by 8:"
{ $description "Find the entry-wise norm of a matrix, in 𝑙ₚ (" { $snippet "L^p" } ") vector space." }
{ $notes "This word is not an induced or Schatten norm, and it is distinct from all of " { $links matrix-l1-norm matrix-l2-norm matrix-l-infinity-norm } "." }
{ $examples
- { $example
+ { $example
"USING: math.matrices prettyprint ;"
"4 4 1 <matrix> 2 matrix-p-norm-entrywise ."
"4.0"
- }
+ }
} ;
HELP: matrix-p-norm
}
{ $examples
"Calls " { $link l1-norm } ":"
- { $example
+ { $example
"USING: math.matrices prettyprint ;"
"4 4 1 <matrix> 1 matrix-p-norm ."
"4"
- }
+ }
"Falls back to " { $link matrix-p-norm-entrywise } ":"
- { $example
+ { $example
"USING: math.functions math.matrices prettyprint ;"
"2 2 3 <matrix> 1.5 matrix-p-norm 7.559 10e-4 ~ ."
"t"
- }
+ }
} ;
{ matrix-p-norm matrix-p-norm-entrywise } related-words
{ $values { "m" "a matrix with at least 1 non-zero number" } { "m'" matrix } }
{ $description "Normalize a matrix containing at least 1 non-zero element. Each element from the input matrix is computed as a fraction of the maximum element. The maximum element becomes " { $snippet "1/1" } "." }
{ $notelist
- $2d-only-note
- { $matrix-scalar-note max abs / }
+ $2d-only-note
+ { $matrix-scalar-note max abs / }
}
{ $examples
- { $example
+ { $example
"USING: math.matrices prettyprint ;"
"{ { 5 9 } { 15 17 } } matrix-normalize ."
"{ { 5/17 9/17 } { 15/17 1 } }"
- }
+ }
} ;
HELP: main-diagonal
{ { 4 3 2 1 } } [ { 1 2 3 4 } <anti-diagonal-matrix> transpose anti-diagonal ] unit-test
{ {
- { 1 4 7 }
- { 2 5 8 }
- { 3 6 9 }
+ { 1 4 7 }
+ { 2 5 8 }
+ { 3 6 9 }
} } [ {
- { 1 2 3 }
- { 4 5 6 }
- { 7 8 9 }
+ { 1 2 3 }
+ { 4 5 6 }
+ { 7 8 9 }
} transpose ] unit-test
! anti transposition
{ { 4 3 2 1 } } [ { 1 2 3 4 } <diagonal-matrix> anti-transpose main-diagonal ] unit-test
{ {
- { 9 6 3 }
- { 8 5 2 }
- { 7 4 1 }
+ { 9 6 3 }
+ { 8 5 2 }
+ { 7 4 1 }
} } [ {
- { 1 2 3 }
- { 4 5 6 }
- { 7 8 9 }
+ { 1 2 3 }
+ { 4 5 6 }
+ { 7 8 9 }
} anti-transpose ] unit-test
<PRIVATE
CONSTANT: upload1 "------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Disposition: form-data; name=\"file1\"; filename=\"up.txt\"\r\nContent-Type: text/plain\r\n\r\nuploaded!\n\r\n------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Disposition: form-data; name=\"file2\"; filename=\"\"\r\n\r\n\r\n------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Disposition: form-data; name=\"file3\"; filename=\"\"\r\n\r\n\r\n------WebKitFormBoundary6odjpVPXIighAE2L\r\nContent-Disposition: form-data; name=\"text1\"\r\n\r\nlol\r\n------WebKitFormBoundary6odjpVPXIighAE2L--\r\n"
: mime-test-stream ( -- stream )
- upload1
- [ "mime" "test" unique-file ] with-temp-directory
- ascii [ set-file-contents ] [ <file-reader> ] 2bi ;
+ upload1
+ [ "mime" "test" unique-file ] with-temp-directory
+ ascii [ set-file-contents ] [ <file-reader> ] 2bi ;
{ } [ mime-test-stream [ ] with-input-stream ] unit-test
HELP: mime-db
{ $values
- { "seq" sequence } }
+ { "seq" sequence } }
{ $description "Outputs an array where the first element is a MIME type and the rest of the array is file extensions that have that MIME type." } ;
HELP: mime-type
HELP: mime-types
{ $values
- { "assoc" assoc } }
+ { "assoc" assoc } }
{ $description "Outputs an " { $snippet "assoc" } " made from the data in the " { $link mime-db } " word where the keys are file extensions and the values are the corresponding MIME types." } ;
HELP: nonstandard-mime-types
{ $values
- { "assoc" assoc } }
+ { "assoc" assoc } }
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
ARTICLE: "mime.types" "MIME types"
{
T{ ebnf-rule f
- "digit"
- T{ ebnf-choice f
+ "digit"
+ T{ ebnf-choice f
V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
+ }
}
} [
"digit = '1' | '2'" rule-parser parse
{
T{ ebnf-rule f
- "digit"
- T{ ebnf-sequence f
- V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
+ "digit"
+ T{ ebnf-sequence f
+ V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
+ }
}
} [
"digit = '1' '2'" rule-parser parse
{
T{ ebnf-choice f
- V{
- T{ ebnf-sequence f
- V{ T{ ebnf-non-terminal f "one" } T{ ebnf-non-terminal f "two" } }
- }
- T{ ebnf-non-terminal f "three" }
- }
+ V{
+ T{ ebnf-sequence f
+ V{ T{ ebnf-non-terminal f "one" } T{ ebnf-non-terminal f "two" } }
+ }
+ T{ ebnf-non-terminal f "three" }
+ }
}
} [
"one two | three" choice-parser parse
{
T{ ebnf-sequence f
- V{
+ V{
T{ ebnf-non-terminal f "one" }
T{ ebnf-whitespace f
T{ ebnf-choice f
{
T{ ebnf-sequence f
- V{
+ V{
T{ ebnf-non-terminal f "one" }
T{ ebnf-repeat0 f
T{ ebnf-sequence f
{
T{ ebnf-sequence f
- V{
+ V{
T{ ebnf-non-terminal f "one" }
T{ ebnf-ignore f
T{ ebnf-sequence f
{
T{ ebnf-sequence f
- V{
+ V{
T{ ebnf-non-terminal f "one" }
T{ ebnf-optional f T{ ebnf-non-terminal f "two" } }
T{ ebnf-non-terminal f "three" }
] choice* ;
: action-parser ( -- parser )
- "[[" factor-code-parser "]]" syntax-pack ;
+ "[[" factor-code-parser "]]" syntax-pack ;
: semantic-parser ( -- parser )
- "?[" factor-code-parser "]?" syntax-pack ;
+ "?[" factor-code-parser "]?" syntax-pack ;
: sequence-parser ( -- parser )
! A sequence of terminals and non-terminals, including
" " %
%
" nip ]" %
- ] "" make
+ ] "" make
] if
] if ;
M: persistent-hash assoc-size count>> ;
M: persistent-hash at*
- [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
- dup [ value>> t ] [ f ] if ;
+ [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at)
+ dup [ value>> t ] [ f ] if ;
M: persistent-hash new-at
[
: read-char ( byte -- ch )
dup CHAR: = = [
- drop read1 dup CHAR: \n =
- [ drop read1 read-char ]
- [ read1 2array hex> ] if
+ drop read1 dup CHAR: \n =
+ [ drop read1 read-char ]
+ [ read1 2array hex> ] if
] when ;
: read-quoted ( -- bytes )
HELP: randomize
{ $values
- { "seq" sequence }
- { "randomized" sequence }
+ { "seq" sequence }
+ { "randomized" sequence }
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
HELP: delete-random
{ $values
- { "seq" sequence }
- { "elt" object } }
+ { "seq" sequence }
+ { "elt" object } }
{ $description "Deletes a random number from a sequence using " { $link remove-nth! } " and returns the deleted object." } ;
ARTICLE: "random-protocol" "Random protocol"
[ endian-shuffle ] dip hrshift endian-shuffle ; inline
: wA ( w -- wA )
- dup 1 hlshift* vbitxor ; inline
+ dup 1 hlshift* vbitxor ; inline
: wB ( w mask -- wB )
- [ 11 vrshift ] dip vbitand ; inline
+ [ 11 vrshift ] dip vbitand ; inline
: wC ( w -- wC )
- 1 hrshift* ; inline
+ 1 hrshift* ; inline
: wD ( w -- wD )
- 18 vlshift ; inline
+ 18 vlshift ; inline
: formula ( a b mask c d -- r )
[ wC ] dip wD vbitxor
{ } [
[ 2 = [ "not 2!" throw ] unless ]
- 1.1 100 <exponential-wait> 3 retries
+ 1.1 100 <exponential-wait> 3 retries
] unit-test
HELP: nappend
{ $values
- { "n" integer }
- { "seq" sequence }
+ { "n" integer }
+ { "seq" sequence }
}
{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
HELP: nappend-as
{ $values
- { "n" integer } { "exemplar" sequence }
- { "seq" sequence }
+ { "n" integer } { "exemplar" sequence }
+ { "seq" sequence }
}
{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
HELP: find-numbers
{ $values
- { "sequence" sequence }
- { "sequence'" sequence }
+ { "sequence" sequence }
+ { "sequence'" sequence }
}
{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
HELP: human<=>
{ $values
- { "obj1" object } { "obj2" object }
- { "<=>" "an ordering specifier" }
+ { "obj1" object } { "obj2" object }
+ { "<=>" "an ordering specifier" }
}
{ $description "Compares two objects after converting numbers in the string into integers." } ;
HELP: human>=<
{ $values
- { "obj1" object } { "obj2" object }
- { ">=<" "an ordering specifier" }
+ { "obj1" object } { "obj2" object }
+ { ">=<" "an ordering specifier" }
}
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
HELP: sort-by
{ $values
- { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "seq'" sequence }
+ { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
+ { "seq'" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
: pprint-direct-array ( direct-array -- )
\ c-array@ [
- [ underlying-type ] [ underlying>> ] [ length>> ] tri
- [ pprint* ] tri@
- ] pprint-prefix ;
+ [ underlying-type ] [ underlying>> ] [ length>> ] tri
+ [ pprint* ] tri@
+ ] pprint-prefix ;
M: specialized-array pprint*
[ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
HELP: monotonic-split-slice
{ $values
- { "seq" sequence } { "quot" { $quotation ( obj1 obj2 -- ? ) } }
- { "pieces" "a sequence of slices" }
+ { "seq" sequence } { "quot" { $quotation ( obj1 obj2 -- ? ) } }
+ { "pieces" "a sequence of slices" }
}
{ $description "Monotonically splits a sequence into slices." }
{ $examples
HELP: monotonic-split
{ $values
- { "seq" sequence } { "quot" quotation }
- { "pieces" "a sequence of sequences" }
+ { "seq" sequence } { "quot" quotation }
+ { "pieces" "a sequence of sequences" }
}
{ $description "Splits a sequence into subsequences, in which for all consecutive pairs of elements the quotation returns true." }
{ $examples
HELP: downward-slices
{ $values
- { "seq" sequence }
- { "slices" "a sequence of downward-slices" }
+ { "seq" sequence }
+ { "slices" "a sequence of downward-slices" }
}
{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
HELP: >suffix-array
{ $values
- { "seq" sequence }
- { "suffix-array" array } }
+ { "seq" sequence }
+ { "suffix-array" array } }
{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ;
HELP: SA{
HELP: suffixes
{ $values
- { "string" string }
- { "suffixes-seq" "a sequence of slices" } }
+ { "string" string }
+ { "suffixes-seq" "a sequence of slices" } }
{ $description "Returns a sequence of tail slices of the input string." } ;
HELP: query
{ $values
- { "begin" sequence } { "suffix-array" "a suffix-array" }
- { "matches" array } }
+ { "begin" sequence } { "suffix-array" "a suffix-array" }
+ { "matches" array } }
{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ;
ARTICLE: "suffix-arrays" "Suffix arrays"
PRIVATE>
: uname ( -- seq )
- SYS_NMLN [ (uname) ] [ group ] bi
- dup length utsname-items assert=
- [ >string [ zero? ] trim-tail ] map ;
+ SYS_NMLN [ (uname) ] [ group ] bi
+ dup length utsname-items assert=
+ [ >string [ zero? ] trim-tail ] map ;
: sysname ( -- string ) 0 uname nth ;
: nodename ( -- string ) 1 uname nth ;
HELP: every
{ $values
- { "quot" quotation } { "interval-duration" duration }
- { "timer" timer } }
+ { "quot" quotation } { "interval-duration" duration }
+ { "timer" timer } }
{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }
{ $examples
{ $code
HELP: delayed-every
{ $values
- { "quot" quotation } { "duration" duration }
- { "timer" timer } }
+ { "quot" quotation } { "duration" duration }
+ { "timer" timer } }
{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }
{ $examples
{ $code
HELP: reset
{ $values
- { "word" word } }
+ { "word" word } }
{ $description "Resets any annotations on a word." }
{ $notes "This word will remove a " { $link watch } "." } ;
HELP: watch-vars
{ $values
- { "word" word } { "vars" "a sequence of symbols" } }
+ { "word" word } { "vars" "a sequence of symbols" } }
{ $description "Annotates a word definition to print the " { $snippet "vars" } " upon entering the word. This word is useful for debugging." } ;
HELP: add-timing
"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
{ $code "\"hello-ui\" deploy" }
{ $list
- { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
- { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
- { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+ { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+ { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+ { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
}
"On all platforms, running the program will display a window with a message." ;
HELP: directory.
{ $values
- { "path" "a pathname string" }
+ { "path" "a pathname string" }
}
{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
test-failures [ V{ } clone ] initialize
T{ error-type-holder
- { type +test-failure+ }
- { word ":test-failures" }
- { plural "unit test failures" }
- { icon "vocab:ui/tools/error-list/icons/unit-test-error.png" }
- { quot [ test-failures get ] }
+ { type +test-failure+ }
+ { word ":test-failures" }
+ { plural "unit test failures" }
+ { icon "vocab:ui/tools/error-list/icons/unit-test-error.png" }
+ { quot [ test-failures get ] }
} define-error-type
SYMBOL: silent-tests?
: gdk-key-release-event ( -- event )
S{ GdkEventKey
- { type 9 }
- { window ALIEN: 1672900 }
- { send_event 0 }
- { time 1332590199 }
- { state 17 }
- { keyval 72 }
- { length 1 }
- { string ALIEN: 1b25c80 }
- { hardware_keycode 43 }
- { group 0 }
- { is_modifier 0 }
+ { type 9 }
+ { window ALIEN: 1672900 }
+ { send_event 0 }
+ { time 1332590199 }
+ { state 17 }
+ { keyval 72 }
+ { length 1 }
+ { string ALIEN: 1b25c80 }
+ { hardware_keycode 43 }
+ { group 0 }
+ { is_modifier 0 }
} ;
: gdk-key-press-event ( -- event )
S{ GdkEventKey
- { type 8 }
- { window ALIEN: 16727e0 }
- { send_event 0 }
- { time 1332864912 }
- { state 16 }
- { keyval 65471 }
- { length 0 }
- { string ALIEN: 19c9700 }
- { hardware_keycode 68 }
- { group 0 }
- { is_modifier 0 }
+ { type 8 }
+ { window ALIEN: 16727e0 }
+ { send_event 0 }
+ { time 1332864912 }
+ { state 16 }
+ { keyval 65471 }
+ { length 0 }
+ { string ALIEN: 19c9700 }
+ { hardware_keycode 68 }
+ { group 0 }
+ { is_modifier 0 }
} ;
: gdk-space-key-press-event ( -- event )
S{ GdkEventKey
- { type 8 }
- { window ALIEN: 1b66360 }
- { send_event 0 }
- { time 28246628 }
- { state 0 }
- { keyval 32 }
- { length 0 }
- { string ALIEN: 20233b0 }
- { hardware_keycode 64 }
- { group 0 }
- { is_modifier 1 }
+ { type 8 }
+ { window ALIEN: 1b66360 }
+ { send_event 0 }
+ { time 28246628 }
+ { state 0 }
+ { keyval 32 }
+ { length 0 }
+ { string ALIEN: 20233b0 }
+ { hardware_keycode 64 }
+ { group 0 }
+ { is_modifier 1 }
} ;
: gdk-windows-key-release-event ( -- event )
S{ GdkEventKey
- { type 9 }
- { window ALIEN: 1a71d80 }
- { send_event 0 }
- { time 47998769 }
- { state 67108928 }
- { keyval 119 }
- { length 1 }
- { string ALIEN: 2017640 }
- { hardware_keycode 25 }
- { group 0 }
- { is_modifier 0 }
+ { type 9 }
+ { window ALIEN: 1a71d80 }
+ { send_event 0 }
+ { time 47998769 }
+ { state 67108928 }
+ { keyval 119 }
+ { length 1 }
+ { string ALIEN: 2017640 }
+ { hardware_keycode 25 }
+ { group 0 }
+ { is_modifier 0 }
} ;
revents>> 0 = not ;
: dispatch ( source callback user-data -- ? )
- 3drop
- 0 mx get-global wait-for-events
- yield t ;
+ 3drop
+ 0 mx get-global wait-for-events
+ yield t ;
: <funcs> ( -- funcs )
GSourceFuncs malloc-struct
ctrl? alt? xor [ ! enable AltGr combination inputs
wParam {
{ [ dup upper-surrogate? ] [
- upper-surrogate-wm-char set-global ]
- }
+ upper-surrogate-wm-char set-global
+ ] }
{ [ dup under-surrogate? ] [
- drop
- upper-surrogate-wm-char get-global [
- wParam "" 2sequence
- utf16n encode utf16n decode hWnd window user-input
- ] when* ]
- }
+ drop
+ upper-surrogate-wm-char get-global [
+ wParam "" 2sequence
+ utf16n encode utf16n decode hWnd window user-input
+ ] when*
+ ] }
[ 1string hWnd window user-input
f upper-surrogate-wm-char set-global ]
} cond
${
""
T{ font
- { name $[ default-sans-serif-font-name ] }
- { size $[ default-font-size ] }
- { foreground $[ text-color ] }
- { background $[ content-background ] }
+ { name $[ default-sans-serif-font-name ] }
+ { size $[ default-font-size ] }
+ { foreground $[ text-color ] }
+ { background $[ content-background ] }
}
} [
<pane> dup current>> smash-line [ text>> ] [ font>> ] bi
: render-tile ( tile x width gadget -- )
[ orientation>> '[ _ v* ] dip ] keep
'[
- _ _ [ dim>> swap ] [ orientation>> ] bi set-axis
- swap draw-scaled-image
+ _ _ [ dim>> swap ] [ orientation>> ] bi set-axis
+ swap draw-scaled-image
] with-translation ;
M: tile-pen draw-interior
{ [ dup jamo? ] [ jamo-class ] }
{ [ dup hangul? ] [ hangul-class ] }
{ [ dup grapheme-control? ] [
- control-class dup ZWJ = [
- drop
- str unclip-last-slice drop dup [
- [ extend? ]
- [ control-class Extend = ]
- [ modifier? ]
- tri or or not
- ] find-last drop [ swap ?nth ] [ last ] if*
- extended-pictographic-table interval-key? [
- (Extended_Pictographic-Extend*-)ZWJ
- ] [ ZWJ ] if
+ control-class dup ZWJ = [
+ drop
+ str unclip-last-slice drop dup [
+ [ extend? ]
+ [ control-class Extend = ]
+ [ modifier? ]
+ tri or or not
+ ] find-last drop [ swap ?nth ] [ last ] if*
+ extended-pictographic-table interval-key? [
+ (Extended_Pictographic-Extend*-)ZWJ
+ ] [ ZWJ ] if
] when
] }
{ [ dup extend? ] [ drop Extend ] }
] if ;
: last-grapheme-from ( end str -- i )
- swap head-slice last-grapheme ;
+ swap head-slice last-grapheme ;
<PRIVATE
HELP: group-id
{ $values
- { "string" string }
- { "id/f" "an integer or f" } }
+ { "string" string }
+ { "id/f" "an integer or f" } }
{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
HELP: group-name
{ $values
- { "id" integer }
- { "string" string } }
+ { "id" integer }
+ { "string" string } }
{ $description "Returns the group name given a group id." } ;
HELP: group-struct
{ $values
- { "obj" object }
- { "group/f" "a group struct or f" } }
+ { "obj" object }
+ { "group/f" "a group struct or f" } }
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
HELP: real-group-id
HELP: set-effective-group
{ $values
- { "obj" object } }
+ { "obj" object } }
{ $description "Sets the effective group id for the current user." } ;
HELP: set-real-group
{ $values
- { "obj" object } }
+ { "obj" object } }
{ $description "Sets the real group id for the current user." } ;
HELP: user-groups
{ $values
- { "string/id" "a string or a group id" }
- { "seq" sequence } }
+ { "string/id" "a string or a group id" }
+ { "seq" sequence } }
{ $description "Returns the sequence of groups to which the user belongs." } ;
HELP: with-effective-group
{ $values
- { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
+ { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
{ $description "Sets the effective group name and calls the quotation. Restores the effective group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-group-cache
{ $values
- { "quot" quotation } }
+ { "quot" quotation } }
{ $description "Iterates over the group file using library calls and creates a cache in the " { $link group-cache } " symbol. The cache is a hashtable indexed by group id. When looking up many groups, this approach is much faster than calling system calls." } ;
HELP: with-real-group
{ $values
- { "string/id/f" "a string or a group id" } { "quot" quotation } }
+ { "string/id/f" "a string or a group id" } { "quot" quotation } }
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: ?group-id
HELP: passwd>new-passwd
{ $values
- { "passwd" "a passwd struct" }
- { "new-passwd" "a passwd tuple" } }
+ { "passwd" "a passwd struct" }
+ { "new-passwd" "a passwd tuple" } }
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
HELP: real-user-name
HELP: user-passwd
{ $values
- { "obj" object }
- { "passwd/f" "passwd or f" } }
+ { "obj" object }
+ { "passwd/f" "passwd or f" } }
{ $description "Returns the passwd tuple given a user-name string or user id." } ;
HELP: user-name
{ $values
- { "id" integer }
- { "string" string } }
+ { "id" integer }
+ { "string" string } }
{ $description "Returns the user-name associated with the user id." } ;
HELP: user-id
{ $values
- { "string" string }
- { "id/f" "an integer or f" } }
+ { "string" string }
+ { "id/f" "an integer or f" } }
{ $description "Returns the user id associated with the user-name." } ;
HELP: with-effective-user
{ $values
- { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-user-cache
{ $values
- { "quot" quotation } }
+ { "quot" quotation } }
{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
HELP: with-real-user
{ $values
- { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
{
HELP: query-param
{ $values
- { "url" url } { "key" string }
+ { "url" url } { "key" string }
{ "value" { $maybe string } } }
{ $description "Outputs the URL-decoded value of a URL query parameter." }
{ $examples
HELP: relative-url?
{ $values
- { "url" url }
- { "?" boolean } }
+ { "url" url }
+ { "?" boolean } }
{ $description "Tests whether a URL is relative." } ;
HELP: redacted-url
with-out-parameters ;
: com-add-ref ( interface -- interface )
- [ IUnknown::AddRef drop ] keep ; inline
+ [ IUnknown::AddRef drop ] keep ; inline
ERROR: null-com-release ;
: com-release ( interface -- )
[ [ { 0 0 } ] dip <RECT> ]
[
[let :> str str selection-start/end
- [
- str string>> dup selection? [ string>> ] when
- swap >utf16-index
- ] bi@
+ [
+ str string>> dup selection? [ string>> ] when
+ swap >utf16-index
+ ] bi@
]
] tri*
! iMinSel
SYMBOL: root
: init-locale ( -- )
- LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
- XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ;
+ LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
+ XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ;
: flush-dpy ( -- ) dpy get XFlush drop ;
PRIVATE>
M: xml clone
- xml clone-slots ;
+ xml clone-slots ;
M: xml like
swap dup xml? [ nip ] [
{ CHAR: \" [ parse-quote ] }
[ drop take-external-id close ]
} case
- ] dip '[ swap _ [ ?set-at ] change ] 2keep ;
+ ] dip '[ swap _ [ ?set-at ] change ] 2keep ;
: take-entity-decl ( -- entity-decl )
pass-blank get-char {
[ values [ interpolated? ] filter ] dip each ; inline
: (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... )
- {
+ {
{ [ over interpolated? ] [ call ] }
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
{ [ over attrs? ] [ each-attrs ] }
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
[ 2drop ]
- } cond ; inline recursive
+ } cond ; inline recursive
: each-interpolated ( xml quot -- )
'[ _ (each-interpolated) ] deep-each ; inline
! Take the substring of a string starting at spot
! from code until the quotation given is true and
! advance spot to after the substring.
- 10 <sbuf> [
- '[ _ keep over [ drop ] [ _ push ] if ] skip-until
- ] keep "" like ; inline
+ 10 <sbuf> [
+ '[ _ keep over [ drop ] [ _ push ] if ] skip-until
+ ] keep "" like ; inline
: take-to ( seq -- string )
'[ _ member? ] take-until ; inline
[ next (parse-quote) ] [ quoteless-attr ] if ; inline
: parse-quote ( -- seq )
- f parse-quote* ;
+ f parse-quote* ;
{ "ns:foo" } [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
: reprints-as ( to from -- )
- [ ] [ string>xml xml>string ] bi-curry* unit-test ;
+ [ ] [ string>xml xml>string ] bi-curry* unit-test ;
: pprint-reprints-as ( to from -- )
- [ ] [ string>xml pprint-xml>string ] bi-curry* unit-test ;
+ [ ] [ string>xml pprint-xml>string ] bi-curry* unit-test ;
: reprints-same ( string -- ) dup reprints-as ;
T{ token f ">" KEYWORD2 }
}
} [
- f "<!ELEMENT %hello; >" "xml" load-mode tokenize-line nip
+ f "<!ELEMENT %hello; >" "xml" load-mode tokenize-line nip
] unit-test
{
T{ token f ">" KEYWORD2 }
}
} [
- f "<!ELEMENT %hello-world; >" "xml" load-mode tokenize-line nip
+ f "<!ELEMENT %hello-world; >" "xml" load-mode tokenize-line nip
] unit-test
{
HELP: assoc-clone-like
{ $values
- { "assoc" assoc } { "exemplar" assoc }
- { "newassoc" assoc } }
+ { "assoc" assoc } { "exemplar" assoc }
+ { "newassoc" assoc } }
{ $description "Outputs a newly-allocated assoc with the same elements as " { $snippet "assoc" } "." }
{ $examples { $example "USING: prettyprint assocs hashtables ;" "H{ { 1 2 } { 3 4 } } { } assoc-clone-like ." "{ { 1 2 } { 3 4 } }" } } ;
HELP: assoc-union-all
{ $values
- { "seq" "a sequence of assocs" }
- { "union" assoc } }
+ { "seq" "a sequence of assocs" }
+ { "union" assoc } }
{ $description "Takes the union of all of the " { $snippet "assocs" } " in " { $snippet "seq" } "." }
{ $examples { $example "USING: prettyprint assocs ;" "{ H{ { 1 2 } } H{ { 3 4 } } } assoc-union-all ." "H{ { 1 2 } { 3 4 } }" } } ;
HELP: assoc-map-as
{ $values
- { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... newkey newvalue ) } } { "exemplar" assoc }
- { "newassoc" assoc } }
+ { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... newkey newvalue ) } } { "exemplar" assoc }
+ { "newassoc" assoc } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the same type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
HELP: extract-keys
{ $values
- { "seq" sequence } { "assoc" assoc }
- { "subassoc" assoc } }
+ { "seq" sequence } { "assoc" assoc }
+ { "subassoc" assoc } }
{ $description "Outputs an new " { $snippet "assoc" } " with key/value pairs whose keys match the elements in the input " { $snippet "seq" } "." }
{ $examples
{ $example "USING: prettyprint assocs ;"
HELP: push-at
{ $values
- { "value" object } { "key" object } { "assoc" assoc } }
+ { "value" object } { "key" object } { "assoc" assoc } }
{ $description "Pushes the " { $snippet "value" } " onto a " { $snippet "vector" } " stored at the " { $snippet "key" } " in the " { $snippet "assoc" } ". If the " { $snippet "key" } " does not yet exist, creates a new " { $snippet "vector" } " at that " { $snippet "key" } " and pushes the " { $snippet "value" } "." }
{ $examples { $example "USING: prettyprint assocs kernel ;"
"H{ { \"cats\" V{ \"Mittens\" } } } \"Mew\" \"cats\" pick push-at ."
HELP: search-alist
{ $values
- { "key" object } { "alist" "an array of key/value pairs" }
- { "pair/f" "a key/value pair" } { "i/f" integer } }
+ { "key" object } { "alist" "an array of key/value pairs" }
+ { "pair/f" "a key/value pair" } { "i/f" integer } }
{ $description "Iterates over " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." }
{ $notes "This word is used to implement " { $link at* } " and " { $link set-at } " on sequences, and should not be called directly." }
{ $examples { $example "USING: prettyprint assocs.private kernel ;"
HELP: unzip
{ $values
- { "assoc" assoc }
- { "keys" sequence } { "values" sequence } }
+ { "assoc" assoc }
+ { "keys" sequence } { "values" sequence } }
{ $description "Outputs an array of keys and an array of values of the input " { $snippet "assoc" } "." }
{ $examples
{ $example "USING: prettyprint assocs kernel ;"
HELP: zip
{ $values
- { "keys" sequence } { "values" sequence }
- { "alist" "an array of key/value pairs" } }
+ { "keys" sequence } { "values" sequence }
+ { "alist" "an array of key/value pairs" } }
{ $description "Combines two sequences pairwise into a single sequence of key/value pairs." }
{ $examples
{ $example "USING: prettyprint assocs ;"
HELP: zip-as
{ $values
- { "keys" sequence } { "values" sequence } { "exemplar" sequence }
- { "assoc" "a sequence of key/value pairs of type " { $snippet "exemplar" } } }
+ { "keys" sequence } { "values" sequence } { "exemplar" sequence }
+ { "assoc" "a sequence of key/value pairs of type " { $snippet "exemplar" } } }
{ $description "Combines two sequences pairwise into a single sequence of key/value pairs of type " { $snippet "exemplar" } "." }
{ $notes "Exemplar must be a sequence type; hashtables will not work yet." }
{ $examples
] if ; inline
: zip ( keys values -- alist )
- { } zip-as ; inline
+ { } zip-as ; inline
: zip-index-as ( values exemplar -- assoc )
[ dup length <iota> ] dip zip-as ; inline
HELP: 1byte-array
{ $values
- { "x" object }
- { "byte-array" byte-array } }
+ { "x" object }
+ { "byte-array" byte-array } }
{ $description "Creates a new byte-array with one element." } ;
HELP: 2byte-array
{ $values
- { "x" object } { "y" object }
- { "byte-array" byte-array } }
+ { "x" object } { "y" object }
+ { "byte-array" byte-array } }
{ $description "Creates a new byte-array with two elements." } ;
HELP: 3byte-array
{ $values
- { "x" object } { "y" object } { "z" object }
- { "byte-array" byte-array } }
+ { "x" object } { "y" object } { "z" object }
+ { "byte-array" byte-array } }
{ $description "Creates a new byte-array with three element." } ;
HELP: 4byte-array
{ $values
- { "w" object } { "x" object } { "y" object } { "z" object }
- { "byte-array" byte-array } }
+ { "w" object } { "x" object } { "y" object } { "z" object }
+ { "byte-array" byte-array } }
{ $description "Creates a new byte-array with four elements." } ;
{ 1byte-array 2byte-array 3byte-array 4byte-array } related-words
HELP: superclasses-of
{ $values
- { "class" class }
- { "supers" sequence } }
+ { "class" class }
+ { "supers" sequence } }
{ $description "Outputs a sequence of superclasses of a class along with the class itself." }
{ $examples
{ $example "USING: classes prettyprint ;"
HELP: instance?
{ $values
- { "object" object } { "class" class }
- { "?" boolean } }
+ { "object" object } { "class" class }
+ { "?" boolean } }
{ $description "Tests whether the input object is a member of the class." } ;
HELP: reset-class
: cond-test-6 ( a -- b )
{
- [ drop "really early" ]
- { [ dup 2 mod 1 = ] [ drop "odd" ] }
- { [ dup 2 mod 0 = ] [ drop "even" ] }
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
} cond ;
{ "really early" } [ 2 cond-test-6 ] unit-test
HELP: n&&
{ $values
- { "quots" "a sequence of quotations" } { "n" integer }
- { "quot" quotation } }
+ { "quots" "a sequence of quotations" } { "n" integer }
+ { "quot" quotation } }
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
HELP: n||
{ $values
- { "quots" "a sequence of quotations" } { "n" integer }
- { "quot" quotation } }
+ { "quots" "a sequence of quotations" } { "n" integer }
+ { "quot" quotation } }
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
HELP: attempt-all
{ $values
- { "seq" sequence } { "quot" quotation }
- { "obj" object } }
+ { "seq" sequence } { "quot" quotation }
+ { "obj" object } }
{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
{ $examples "The first two numbers throw, the last one doesn't:"
{ $example
HELP: with-return
{ $values
- { "quot" quotation } }
+ { "quot" quotation } }
{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediately after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
{ $examples
"Only \"Hi\" will print:"
HELP: dispose-each
{ $values
- { "seq" sequence } }
+ { "seq" sequence } }
{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ;
HELP: disposables
HELP: n*quot
{ $values
- { "n" integer } { "quot" quotation }
- { "quotquot" quotation }
+ { "n" integer } { "quot" quotation }
+ { "quotquot" quotation }
}
{ $examples
{ $example "USING: generalizations prettyprint math ;"
<PRIVATE
: (closure) ( vertex set quot: ( vertex -- edges ) -- )
- 2over ?adjoin [
- [ dip ] keep [ (closure) ] 2curry each
- ] [ 3drop ] if ; inline recursive
+ 2over ?adjoin [
+ [ dip ] keep [ (closure) ] 2curry each
+ ] [ 3drop ] if ; inline recursive
: new-empty-set-like ( exemplar -- set )
- f swap set-like clone ; inline
+ f swap set-like clone ; inline
PRIVATE>
[ 0 0 ] dip <hash-array> hash-set boa ; inline
M: hash-set in?
- key@ 2nip ;
+ key@ 2nip ;
M: hash-set clear-set
[ init-hash ] [ array>> [ drop +empty+ ] map! drop ] bi ;
HELP: ?set-at
{ $values
- { "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } }
- { "assoc" assoc } }
+ { "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } }
+ { "assoc" assoc } }
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
HELP: >hashtable
HELP: decode-input
{ $values
- { "encoding" "an encoding descriptor" }
+ { "encoding" "an encoding descriptor" }
}
{ $description "Changes the encoding of the current input stream stored in the " { $link input-stream } " variable." } ;
HELP: encode-output
{ $values
- { "encoding" "an encoding descriptor" }
+ { "encoding" "an encoding descriptor" }
}
{ $description "Changes the encoding of the current output stream stored in the " { $link output-stream } " variable." } ;
HELP: re-decode
{ $values
- { "stream" "a stream" } { "encoding" "an encoding descriptor" }
- { "newstream" "a new stream" }
+ { "stream" "a stream" } { "encoding" "an encoding descriptor" }
+ { "newstream" "a new stream" }
}
{ $description "Creates a new decoding stream with the supplied encoding descriptor from an existing stream by calling the " { $link <decoder> } " word." } ;
HELP: re-encode
{ $values
- { "stream" "a stream" } { "encoding" "an encoding descriptor" }
- { "newstream" "a new stream" }
+ { "stream" "a stream" } { "encoding" "an encoding descriptor" }
+ { "newstream" "a new stream" }
}
{ $description "Creates a new encoding stream with the supplied encoding descriptor from an existing stream by calling the " { $link <encoder> } " word." } ;
HELP: with-decoded-input
{ $values
- { "encoding" "an encoding descriptor" } { "quot" quotation }
+ { "encoding" "an encoding descriptor" } { "quot" quotation }
}
{ $description "Creates a new decoding stream with the given encoding descriptor and calls the quotation with this stream set to the " { $link input-stream } " variable. The original decoder stream is restored after the quotation returns and the stream is kept open for future input operations." } ;
HELP: with-encoded-output
{ $values
- { "encoding" "an encoding descriptor" } { "quot" quotation }
+ { "encoding" "an encoding descriptor" } { "quot" quotation }
}
{ $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ;
{
"1234"
} [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- 4 swap stream-read
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ 4 swap stream-read
] unit-test
{
"1234"
} [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- 4 swap stream-read-partial
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ 4 swap stream-read-partial
] unit-test
{
CHAR: 1
} [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- stream-read1
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ stream-read1
] unit-test
{ utf8 ascii } [
HELP: stream-read-partial
{ $values
- { "n" "a non-negative integer" } { "stream" "an input stream" }
- { "seq/f" { $or byte-array string f } } }
+ { "n" "a non-negative integer" } { "stream" "an input stream" }
+ { "seq/f" { $or byte-array string f } } }
{ $description "Reads at most " { $snippet "n" } " elements from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
HELP: stream-read-partial-unsafe
HELP: stream-tell
{ $values
- { "stream" "a stream" } { "n" integer }
+ { "stream" "a stream" } { "n" integer }
}
{ $description "Returns the index of the stream pointer if the stream is seekable." }
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: stream-seek
{ $values
- { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
+ { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
}
{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
"Three methods of seeking are supported:"
HELP: stream-seekable?
{ $values
- { "stream" "a stream" } { "?" boolean }
+ { "stream" "a stream" } { "?" boolean }
}
{ $description "Returns true if " { $snippet "stream" } " is a seekable stream." }
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: stream-length
{ $values
- { "stream" "a stream" } { "n/f" { $maybe integer } }
+ { "stream" "a stream" } { "n/f" { $maybe integer } }
}
{ $description "Returns the length of the data supplied by " { $snippet "stream" } ", or " { $link f } " if the stream is not seekable or has unknown length." }
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: seek-absolute
{ $values
-
- { "value" "a seek singleton" }
+ { "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the beginning of the stream." } ;
HELP: seek-end
{ $values
-
- { "value" "a seek singleton" }
+ { "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
HELP: seek-relative
{ $values
-
- { "value" "a seek singleton" }
+ { "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
HELP: seek-input
{ $values
- { "n" integer } { "seek-type" "a seek singleton" }
+ { "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
HELP: seek-output
{ $values
- { "n" integer } { "seek-type" "a seek singleton" }
+ { "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
<PRIVATE
: read-loop ( buf stream n i -- count )
- 2dup = [ 3nip ] [
+ 2dup = [ 3nip ] [
pick stream-read1 [
over [ pick set-nth-unsafe ] 2curry 3dip
1 + read-loop
] [ 3nip ] if*
- ] if ; inline recursive
+ ] if ; inline recursive
: finalize-read-until ( seq sep/f -- seq/f sep/f )
2dup [ empty? ] [ not ] bi* and [ 2drop f f ] when ; inline
HELP: loop
{ $values
- { "pred" quotation } }
- { $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
+ { "pred" quotation } }
+ { $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
{ $examples "Loop until we hit a zero:"
{ $unchecked-example "USING: kernel random math io ; "
" [ \"hi\" write bl 10 random zero? not ] loop"
M: integer ed's-bug neg ;
:: ed's-test-case ( a -- b )
- { [ a ed's-bug ] } && ;
+ { [ a ed's-bug ] } && ;
{ t } [ \ ed's-test-case word-optimized? ] unit-test
HELP: when-zero
{ $values
- { "n" number } { "quot" "the first quotation of an " { $link if-zero } } { "x" object } }
+ { "n" number } { "quot" "the first quotation of an " { $link if-zero } } { "x" object } }
{ $description "Makes an implicit check if the number is zero. A zero is dropped and the " { $snippet "quot" } " is called." }
{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:"
{ $example
HELP: unless-zero
{ $values
- { "n" number } { "quot" "the second quotation of an " { $link if-zero } } }
+ { "n" number } { "quot" "the second quotation of an " { $link if-zero } } }
{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." }
{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
{ $example
HELP: until-zero
{ $values
- { "n" number } { "quot" { $quotation ( ... x -- ... y ) } } }
+ { "n" number } { "quot" { $quotation ( ... x -- ... y ) } } }
{ $description "Makes a check if the number is zero, and repeatedly calls " { $snippet "quot" } " until the value on the stack is zero." }
{ $examples
{ $example
-rot 10 >>radix 0 ; inline
: <float-parse> ( i number-parse n -- float-parse i number-parse n )
- [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
+ [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
: if-skip ( char true false -- )
pick ",_" member-eq? [ drop nip call ] [ nip call ] if ; inline
{ $values
{ "seq" sequence }
{ "newseq" sequence } }
- { $description "Outputs a new sequence with all instances of " { $link f } " removed." }
- { $examples
+{ $description "Outputs a new sequence with all instances of " { $link f } " removed." }
+{ $examples
{ $example "USING: prettyprint sequences ;"
"{ \"a\" 3 { } f } sift ."
"{ \"a\" 3 { } }"
{ $values
{ "len" integer } { "quot" { $quotation ( ... -- ... newelt ) } } { "exemplar" sequence }
{ "newseq" sequence } }
- { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
+{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
"5 [ 100 random ] B{ } replicate-as ."
{ $values
{ "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation ( ..a elt1 elt2 -- ..a intermediate ) } } { "reduce-quot" { $quotation ( ..a prev intermediate -- ..a next ) } }
{ "result" object } }
- { $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." }
+{ $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." }
{ $errors "Throws an error if the sequence is empty." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 30 50 } { 200 400 600 } [ + ] [ + ] 2map-reduce ."
] keep ;
: reverse ( seq -- newseq )
- [
+ [
dup [ length ] keep new-sequence
[ 0 swap copy-unsafe ] keep reverse!
] keep like ;
}
"Utilities for sets and sequences:"
{ $subsections
- within
- without
+ within
+ without
} ;
ARTICLE: "set-implementations" "Set implementations"
HELP: gather
{ $values
- { "seq" sequence } { "quot" { $quotation ( ... elt -- ... elts ) } }
- { "newseq" sequence } }
+ { "seq" sequence } { "quot" { $quotation ( ... elt -- ... elts ) } }
+ { "newseq" sequence } }
{ $description "Maps a quotation over a sequence, concatenates the results of the mapping, and removes duplicates." } ;
HELP: set-like
{ $subsections POSTPONE: NAN: }
"To see the 64 bit value of " { $snippet "0/0." } " on your platform, execute the following code :"
{ $code
- "USING: io math math.parser ;"
- "\"NAN: \" write 0/0. double>bits >hex print"
+ "USING: io math math.parser ;"
+ "\"NAN: \" write 0/0. double>bits >hex print"
}
"Hexadecimal, octal and binary float literals are also supported. These consist of a hexadecimal, octal or binary literal with a decimal point and a mandatory base-two exponent expressed as a decimal number after " { $snippet "p" } " or " { $snippet "P" } ":"
{ $example
}
}
}
- } ;
+ } ;
SYMBOL: elements
! Modifies assoc1
: assoc-merge! ( assoc1 assoc2 quot: ( value1 value2 -- new-value ) -- assoc1' )
[| key2 val2 quot | val2 key2 pick
- at* [ swap quot call ] [ drop ] if
- key2 pick set-at ] curry assoc-each ; inline
+ at* [ swap quot call ] [ drop ] if
+ key2 pick set-at ] curry assoc-each ; inline
! Same as above, non-destructive
: assoc-merge ( assoc1 assoc2 quot: ( value1 value2 -- new-value ) -- new-assoc )
}
{ $description
"If 'gen' is true, the server starts generating bitcoins. If 'gen' is "
- "'false' then the server stops generating bitcoins. 'n' is the number "
- "of CPU's to use while generating. A value of '-1' means use all the "
- "CPU's available."
+ "'false' then the server stops generating bitcoins. 'n' is the number "
+ "of CPU's to use while generating. A value of '-1' means use all the "
+ "CPU's available."
} ;
HELP: get-info
-6.0 4.0 glVertex2f
-6.0 -4.0 glVertex2f
8.0 0.0 glVertex2f
- ] do-state
+ ] do-state
] with-translation ;
: draw-boids ( boids -- )
{ gmt-offset T{ duration { hour 2 } } } } } } turnaround
] unit-test
-{ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
- { "ref" T{ dbref f "a" "b" "c" } }
- { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
- { "quot" [ 1 2 + ] } }
-}
-[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
- { "ref" T{ dbref f "a" "b" "c" } }
- { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
- { "quot" [ 1 2 + ] } } turnaround ] unit-test
+{
+ H{
+ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
+ { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+ { "quot" [ 1 2 + ] }
+ }
+} [
+ H{
+ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
+ { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+ { "quot" [ 1 2 + ] }
+ } turnaround
+] unit-test
TUPLE: mdbregexp { regexp string } { options string } ;
: <mdbregexp> ( string -- mdbregexp )
- [ mdbregexp new ] dip >>regexp ;
+ [ mdbregexp new ] dip >>regexp ;
CONSTANT: MDB_OID_FIELD "_id"
read-int32 [ f ] [ drop read-elements t ] if-zero ; inline recursive
: bson-binary-read ( -- binary )
- read-int32 read-byte
- {
+ read-int32 read-byte
+ {
{ T_Binary_Default [ read ] }
{ T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
{ T_Binary_Custom [ read bytes>object ] }
{ T_Binary_MD5 [ read >string ] }
{ T_Binary_UUID [ read >string ] }
[ "unknown binary sub-type" unknown-bson-type ]
- } case ; inline
+ } case ; inline
TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
- mdbregexp new
- read-cstring >>regexp read-cstring >>options ; inline
+ mdbregexp new
+ read-cstring >>regexp read-cstring >>options ; inline
TYPED: bson-oid-read ( -- oid: oid )
read-longlong read-int32 oid boa ; inline
[ T_Binary_Default write1 write ] bi ; inline
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
- [ regexp>> write-cstring ]
- [ options>> write-cstring ] bi ; inline
+ [ regexp>> write-cstring ]
+ [ options>> write-cstring ] bi ; inline
TYPED: write-sequence ( array: sequence -- )
- '[
+ '[
_ [ number>string swap write-pair ] each-index
write-eoo
] with-length-prefix ; inline recursive
TYPED: write-assoc ( assoc: hashtables -- )
'[ _ [ write-oid-field ] [
[ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
- ] bi write-eoo
+ ] bi write-eoo
] with-length-prefix ; inline recursive
UNION: code word quotation ;
drop f >>processing-disabled?
[ 1 - ] change-ifdef-nesting
drop
- ] [ 2drop ] if
+ ] [ 2drop ] if
] [
parse-directive
] if ;
: parse-post ( -- assoc )
"CONTENT_TYPE" os-env "" or content-type {
- { "multipart/form-data" [ multipart ] }
- { "application/x-www-form-urlencoded" [ urlencoded ] }
- [ drop parse-get ]
- } case nip ;
+ { "multipart/form-data" [ multipart ] }
+ { "application/x-www-form-urlencoded" [ urlencoded ] }
+ [ drop parse-get ]
+ } case nip ;
PRIVATE>
?file-info dup [ directory? ] when ;
: git-current-branch* ( -- name )
- { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ;
+ { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ;
: git-current-branch ( directory -- name )
[ git-current-branch* ] with-directory ;
{ { "negative" 0 "positive" } } [
{ -1 0 1 } [
{
- { [ 0 > ] [ "positive" ] }
- { [ 0 < ] [ "negative" ] }
- [ ]
+ { [ 0 > ] [ "positive" ] }
+ { [ 0 < ] [ "negative" ] }
+ [ ]
} cond-case
] map
] unit-test
swap cpu-f-bitor= ;
: clear-flag ( cpu flag -- )
- bitnot 0xFF bitand swap cpu-f-bitand= ;
+ bitnot 0xFF bitand swap cpu-f-bitand= ;
: update-zero-flag ( result cpu -- )
! If the result of an instruction has the value 0, this
! set-d
{ { 0x01020304 0x02030401 0x03040102 0x04010203 } } [
- { 0x01010101 0x02020202 0x03030303 0x04040404 } shift-rows
+ { 0x01010101 0x02020202 0x03030303 0x04040404 } shift-rows
] unit-test
{ { 0x01010101 0x02020202 0x03030303 0x04040404 } } [
- { 0x01020304 0x02030401 0x03040102 0x04010203 } unshift-rows
+ { 0x01020304 0x02030401 0x03040102 0x04010203 } unshift-rows
] unit-test
{ 0x02030401 } [ 0x01020304 rotword ] unit-test
{
-V{ 729683222 682545830 2885096840 164581180 2700803607 2287217841
- 597899577 711751173 4072838642 2056698179 1496678522 1935275647
- 1031817085 1192689214 505642564 1836746811 4014253377 2823969663
- 3060868411 3674975488 3570517752 2089000327 3404904636 301536700
- 1837671290 285949693 3690563137 3389035517 1314191118 1600113139
- 2225491890 1319558223 3939660577 3045964498 824964448 2139957551
- 2893506291 435870753 684796225 1465647214 3491035560 3387827593
- 3779005640 3059944614 }
+ V{
+ 729683222 682545830 2885096840 164581180 2700803607 2287217841
+ 597899577 711751173 4072838642 2056698179 1496678522 1935275647
+ 1031817085 1192689214 505642564 1836746811 4014253377 2823969663
+ 3060868411 3674975488 3570517752 2089000327 3404904636 301536700
+ 1837671290 285949693 3690563137 3389035517 1314191118 1600113139
+ 2225491890 1319558223 3939660577 3045964498 824964448 2139957551
+ 2893506291 435870753 684796225 1465647214 3491035560 3387827593
+ 3779005640 3059944614
+ }
} [
B{ 0x2b 0x7e 0x15 0x16 0x28 0xae 0xd2 0xa6 0xab 0xf7 0x15 0x88 0x09 0xcf 0x4f 0x3c } ! AES-128 key expansion test vector from FIPS-197 (appendix)
10 (expand-enc-key)
{ 0x046681e5 } [ 0x088df419 ui32> t-transform ] unit-test
-{ V{
- 0x3925841d
- 0x02dc09fb
- 0xdc118597
- 0x196a0b32
- }
+{
+ V{
+ 0x3925841d
+ 0x02dc09fb
+ 0xdc118597
+ 0x196a0b32
+ }
} [
key plaintext aes-encrypt-block bytes>words
] unit-test
c0 gb0 c1 gb1 c2 gb2 c3 gb3 >ui32 ; ! c3'
: (add-round-key) ( key state -- state' )
- 4 [ bitxor ] unrolled-2map ;
+ 4 [ bitxor ] unrolled-2map ;
: add-round-key ( aes n -- aes' )
over (key-at-nth-round) swap
HELP: authenticate-password
{ $values
- { "shadow" string } { "password" string }
- { "?" boolean } }
+ { "shadow" string } { "password" string }
+ { "?" boolean } }
{ $description "Encodes the provided password and compares it to the encoded password entry from a shadowed password file." } ;
HELP: parse-shadow-password
{ $values
- { "string" string }
- { "magic" string } { "salt" string } { "password" string } }
+ { "string" string }
+ { "magic" string } { "salt" string } { "password" string } }
{ $description "Splits a shadowed password entry into a magic string, a salt, and an encoded password string." } ;
HELP: passwd-md5
{ $values
- { "magic" string } { "salt" string } { "password" string }
- { "bytes" "an md5-shadowed password entry" } }
+ { "magic" string } { "salt" string } { "password" string }
+ { "bytes" "an md5-shadowed password entry" } }
{ $description "Encodes the password with the given magic string and salt to an MD5-shadow password entry." } ;
ARTICLE: "crypto.passwd-md5" "MD5 shadow passwords"
M: cuda-function-word definer drop \ CUDA-FUNCTION: \ ; ;
M: cuda-function-word definition drop f ;
M: cuda-function-word synopsis*
- {
- [ seeing-word ]
- [ definer. ]
- [ [ pprint-word ] pprint-cuda-function ]
- } cleave ;
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ [ pprint-word ] pprint-cuda-function ]
+ } cleave ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.private destructors math namespaces
- openssl openssl.libcrypto byte-arrays bit-arrays.private
- alien.c-types alien.destructors alien.data ;
+ openssl openssl.libcrypto byte-arrays bit-arrays.private
+ alien.c-types alien.destructors alien.data ;
IN: ecdsa
ARTICLE: "elevate" "Elevated permissions API"
"The " { $vocab-link "elevate" } " vocabulary provides abstractions for running programs with elevated (administrator) privileges (permissions). It allows code to relaunch itself or other programs with administrator privileges after requiring a password."
$nl
- "This vocabulary is inspired by and ported from " { $url "https://github.com/barneygale/elevate" "Barney Gale's elevate.py" } "."
+ "This vocabulary is inspired by and ported from " { $url "https://github.com/barneygale/elevate" "Barney Gale's elevate.py" } "."
$nl
{ $subsections already-root? elevate elevated lowered }
"However, there are many caveats: " { $link "elevate.bugs" } "." ;
CONSTANT: debug-text-font
T{ font
- { name "monospace" }
- { size 16 }
- { bold? f }
- { italic? f }
- { foreground COLOR: white }
- { background COLOR: black } }
+ { name "monospace" }
+ { size 16 }
+ { bold? f }
+ { italic? f }
+ { foreground COLOR: white }
+ { background COLOR: black } }
CONSTANT: debug-text-texture-parameters
T{ texture-parameters
- { wrap repeat-texcoord }
- { min-filter filter-linear }
- { min-mipmap-filter f } }
+ { wrap repeat-texcoord }
+ { min-filter filter-linear }
+ { min-mipmap-filter f } }
: text>image ( string color -- image )
debug-text-font clone swap >>foreground swap string>image drop ;
wdt cols /i :> cellwidth
hgt rows /i :> cellheight
- cellwidth cellheight { } 2sequence ;
+ cellwidth cellheight { } 2sequence ;
:: get-dimension-matrix ( n gadget -- matrix )
! gets a matrix of all starting locations of cells
! SECTION: gadget methods
M: board-gadget pref-dim*
- dimension>> ;
+ dimension>> ;
M: board-gadget handle-gesture
swap over gests>> ?at
! Copyright (C) 2023 Keldan Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel coroutines effects.parser words sequences accessors generalizations
- locals.parser summary combinators.smart math continuations make ;
+locals.parser summary combinators.smart math continuations make ;
IN: generators
TUPLE: generator state ;
M: binary-data >uniform-vec-array drop ; inline
M:: object >uniform-matrix ( sequence cols rows -- c-array )
- sequence flip cols head-slice
- [ rows head-slice c:float >c-array ] { } map-as concat ; inline
+ sequence flip cols head-slice
+ [ rows head-slice c:float >c-array ] { } map-as concat ; inline
M: binary-data >uniform-matrix 2drop ; inline
M: object >uniform-matrix-array
- '[ _ _ >uniform-matrix ] map concat ; inline
+ '[ _ _ >uniform-matrix ] map concat ; inline
M: binary-data >uniform-matrix-array 2drop ; inline
M: object bind-uniform-bvec2 ( index sequence -- )
:: <2d-render-texture> ( dim order type -- renderbuffer texture )
order type
T{ texture-parameters
- { wrap clamp-texcoord-to-edge }
- { min-filter filter-linear }
- { min-mipmap-filter f } }
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f } }
<texture-2d> [
0 <texture-2d-attachment> 1array f f dim <framebuffer>
dup { { default-attachment { 0 0 0 } } } clear-framebuffer
swap attributes>> key? ;
: find-all ( seq quot -- alist )
- [ <enumerated> >alist ] [ '[ second @ ] ] bi* filter ; inline
+ [ <enumerated> >alist ] [ '[ second @ ] ] bi* filter ; inline
: loopn-index ( n quot -- )
[ <iota> ] [ '[ @ not ] ] bi* find 2drop ; inline
over tree>> push
after-body-mode >>insertion-mode
- ] }
+ ] }
{ [ dup { [ end-tag? ] [ name>> "html" = ] } 1&& ] [ drop unimplemented* ] }
! { [ ] [ ] }
[
{ [ dup doctype? ] [ drop ] }
{ [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
unimplemented*
- ] }
+ ] }
{ [ dup { [ end-tag? ] [ name>> "html" = ] } 1&& ] [
! XXX: make this a function
"html" pick tree>> find-matching-tag
! RFC7541 Appendix C.2.1
{ T{ hpack-context f 4096 { { "custom-key" "custom-header" } } }
- 26 { "custom-key" "custom-header" } }
+ 26 { "custom-key" "custom-header" } }
[ hpack-context new c21 0 decode-field nipd ] unit-test
! RFC7541 Appendix C.2.2
} cleave ;
{
- "BLAH"
- "ARTIST"
- "ALBUM"
- "2009"
- "COMMENT"
- "Bluegrass"
+ "BLAH"
+ "ARTIST"
+ "ALBUM"
+ "2009"
+ "COMMENT"
+ "Bluegrass"
} [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test
{
} [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test
{
- "Stormy Weather"
- "Frank Sinatra"
- "Night and Day Frank Sinatra"
- f
- "eng, AG# 08E1C12E"
- "Big Band"
+ "Stormy Weather"
+ "Frank Sinatra"
+ "Night and Day Frank Sinatra"
+ f
+ "eng, AG# 08E1C12E"
+ "Big Band"
} [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
read-sub-blocks >>comment-data ;
: read-application-extension ( -- read-application-extension )
- \ application-extension new
- 1 read le> >>block-size
- 8 read utf8 decode >>identifier
- 3 read >>authentication-code
- read-sub-blocks >>application-data ;
+ \ application-extension new
+ 1 read le> >>block-size
+ 8 read utf8 decode >>identifier
+ 3 read >>authentication-code
+ read-sub-blocks >>application-data ;
: read-gif-header ( loading-gif -- loading-gif )
6 read utf8 decode >>magic ;
{ } [ { 50 50 } gen-image "s" set ] unit-test
{ } [ "s" get <image-gadget> "ig" set ] unit-test
"ig" get [
- [ t ] [ "ig" get image-gadget-texture single-texture? ] unit-test
+ [ t ] [ "ig" get image-gadget-texture single-texture? ] unit-test
] with-grafted-gadget
{ } [ "s" get <model> "m" set ] unit-test
{ } [ { 150 150 } gen-image "s1" set ] unit-test
{ } [ "m" get <image-control> "ic" set ] unit-test
"ic" get [
- [ t ] [ "ic" get image-gadget-texture single-texture? ] unit-test
- [ { 50 50 } ] [ "ic" get texture>> texture-size ] unit-test
+ [ t ] [ "ic" get image-gadget-texture single-texture? ] unit-test
+ [ { 50 50 } ] [ "ic" get texture>> texture-size ] unit-test
] with-grafted-gadget
! TODO
] [ f ] if*
] [ f ] if* ;
: same-internal-format? ( image-gadget -- ? )
- [ texture-format ] [ image>> image-format 2drop ] bi = ;
+ [ texture-format ] [ image>> image-format 2drop ] bi = ;
! TODO: also keep multitextures if possible ?
: keep-same-texture? ( image-gadget -- ? )
{ 3 } [ [infix 2*7%3+1 infix] ] unit-test
{ 1419857 } [ [infix 17**5 infix] ] unit-test
{ 1 } [ [infix 2-
- 1
- -5*
- 0 infix] ] unit-test
+ 1
+ -5*
+ 0 infix]
+] unit-test
{ 0.0 } [ [infix sin(0) infix] ] unit-test
{ 10 } [ [infix lcm(2,5) infix] ] unit-test
}
STRUCT: guid_t
- { g_guid { uchar KAUTH_GUID_SIZE } } ;
+ { g_guid { uchar KAUTH_GUID_SIZE } } ;
TYPEDEF: uint kauth_ace_rights_t
STRUCT: kauth_ace
- { ace_applicable guid_t }
- { ace_flags uint }
- { ace_rights kauth_ace_rights_t } ;
+ { ace_applicable guid_t }
+ { ace_flags uint }
+ { ace_rights kauth_ace_rights_t } ;
TYPEDEF: kauth_ace* kauth_ace_t
STRUCT: kauth_acl
- { acl_entrycount uint }
- { acl_flags uint }
- { acl_ace { kauth_ace 1 } } ;
+ { acl_entrycount uint }
+ { acl_flags uint }
+ { acl_ace { kauth_ace 1 } } ;
TYPEDEF: kauth_acl* kauth_acl_t
STRUCT: kauth_filesec
- { fsec_magic uint }
- { fsec_owner guid_t }
- { fsec_group guid_t } ;
+ { fsec_magic uint }
+ { fsec_owner guid_t }
+ { fsec_group guid_t } ;
TYPEDEF: kauth_filesec* kauth_filesec_t
FUNCTION: int acl_dup ( acl_t acl )
f acl_permset_t <ref> [ acl_get_permset acl-error ] keep ;
: filter-strings ( obj strings -- string )
- [ [ 1 = ] dip f ? ] 2map sift "," join ;
+ [ [ 1 = ] dip f ? ] 2map sift "," join ;
: permset>strings ( acl_permset -- strings )
acl-perms [ acl_get_perm_np dup acl-error ] with map
acl-entry>permset permset>strings ;
: with-new-acl ( quot -- )
- [ [ new-acl &free-acl ] dip call ] with-destructors ; inline
+ [ [ new-acl &free-acl ] dip call ] with-destructors ; inline
: acls. ( path -- )
[ acl>text io:write ] acl-each ;
] with-output-stream* ;
M: 256color make-cell-stream
- 2drop <string-writer> <256color> ;
+ 2drop <string-writer> <256color> ;
M: 256color dispose drop ;
] with-output-stream* ;
M: ansi make-cell-stream
-
2drop <string-writer> <ansi> ;
+ 2drop <string-writer> <ansi> ;
M: ansi dispose drop ;
SYMBOL: +server-chat+
: <irc-server-chat> ( -- irc-server-chat )
- irc-server-chat new
+ irc-server-chat new
<mailbox> >>in-messages ;
: <irc-channel-chat> ( name -- irc-channel-chat )
- irc-channel-chat new
+ irc-channel-chat new
swap >>name
<mailbox> >>in-messages
f >>password
t >>clear-participants ;
: <irc-nick-chat> ( name -- irc-nick-chat )
- irc-nick-chat new
+ irc-nick-chat new
swap >>name
<mailbox> >>in-messages ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
- chats is-running nick connect is-ready
- reconnect-time reconnect-attempts
- exceptions ;
+ chats is-running nick connect is-ready
+ reconnect-time reconnect-attempts
+ exceptions ;
: <irc-client> ( profile -- irc-client )
dup nickname>> irc-client new
] unit-test
] spawning-irc
-[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
- { "ircuser" T{ participant { nick "ircuser" } } }
- { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
+[ { H{
+ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
+ { "ircuser" T{ participant { nick "ircuser" } } }
+ { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
"#factortest" <irc-channel-chat>
"ircuser" over join-participant
[ %add-named-chat ] keep
] [ (terminate-irc) ] if* ;
: (do-login) ( -- )
- irc>
- [ profile>> password>> [ /PASS ] when* ]
- [ nick>> /LOGIN ]
- bi ;
+ irc>
+ [ profile>> password>> [ /PASS ] when* ]
+ [ nick>> /LOGIN ]
+ bi ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
[ " has set mode " % mode>> % ]
[ " to " % parameter>> % ]
} cleave
- ] "" make ;
+ ] "" make ;
M: nick >log-line
[ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ privmsg
- { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
- { prefix "someuser!n=user@some.where" }
- { command "PRIVMSG" }
- { parameters { "#factortest" } }
- { trailing "hi" }
- { target "#factortest" }
- { text "hi" }
- { sender "someuser" } } }
+ { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
+ { prefix "someuser!n=user@some.where" }
+ { command "PRIVMSG" }
+ { parameters { "#factortest" } }
+ { trailing "hi" }
+ { target "#factortest" }
+ { text "hi" }
+ { sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
{ T{ join
- { line ":someuser!n=user@some.where JOIN :#factortest" }
- { prefix "someuser!n=user@some.where" }
- { command "JOIN" }
- { parameters { } }
- { trailing "#factortest" }
- { sender "someuser" }
- { channel "#factortest" } } }
+ { line ":someuser!n=user@some.where JOIN :#factortest" }
+ { prefix "someuser!n=user@some.where" }
+ { command "JOIN" }
+ { parameters { } }
+ { trailing "#factortest" }
+ { sender "someuser" }
+ { channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
string>irc-message f >>timestamp ] unit-test
{ T{ mode
- { line ":ircserver.net MODE #factortest +ns" }
- { prefix "ircserver.net" }
- { command "MODE" }
- { parameters { "#factortest" "+ns" } }
- { name "#factortest" }
- { mode "+ns" } } }
+ { line ":ircserver.net MODE #factortest +ns" }
+ { prefix "ircserver.net" }
+ { command "MODE" }
+ { parameters { "#factortest" "+ns" } }
+ { name "#factortest" }
+ { mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
string>irc-message f >>timestamp ] unit-test
{ T{ mode
- { line ":ircserver.net MODE #factortest +o someuser" }
- { prefix "ircserver.net" }
- { command "MODE" }
- { parameters { "#factortest" "+o" "someuser" } }
- { name "#factortest" }
- { mode "+o" }
- { parameter "someuser" } } }
+ { line ":ircserver.net MODE #factortest +o someuser" }
+ { prefix "ircserver.net" }
+ { command "MODE" }
+ { parameters { "#factortest" "+o" "someuser" } }
+ { name "#factortest" }
+ { mode "+o" }
+ { parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
string>irc-message f >>timestamp ] unit-test
{ T{ nick
- { line ":someuser!n=user@some.where NICK :someuser2" }
- { prefix "someuser!n=user@some.where" }
- { command "NICK" }
- { parameters { } }
- { trailing "someuser2" }
- { sender "someuser" }
- { nickname "someuser2" } } }
+ { line ":someuser!n=user@some.where NICK :someuser2" }
+ { prefix "someuser!n=user@some.where" }
+ { command "NICK" }
+ { parameters { } }
+ { trailing "someuser2" }
+ { sender "someuser" }
+ { nickname "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
string>irc-message f >>timestamp ] unit-test
{ T{ rpl-nickname-in-use
- { line ":ircserver.net 433 * nickname :Nickname is already in use" }
- { prefix "ircserver.net" }
- { command "433" }
- { parameters { "*" "nickname" } }
- { name "nickname" }
- { trailing "Nickname is already in use" } } }
+ { line ":ircserver.net 433 * nickname :Nickname is already in use" }
+ { prefix "ircserver.net" }
+ { command "433" }
+ { parameters { "*" "nickname" } }
+ { name "nickname" }
+ { trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
string>irc-message f >>timestamp ] unit-test
<sequence-parser> ;
: skip-after ( sequence-parser seq -- sequence-parser )
- [ take-until-sequence* drop ] curry keep ;
+ [ take-until-sequence* drop ] curry keep ;
: skip-after* ( sequence-parser object -- sequence-parser )
[ take-until-object drop ] curry keep ;
:: S-and-M-can't-be-zero ( seq -- seq' )
seq [| hash |
- 1 hash N1 of lnth 0 = not
- 1 hash N2 of lnth 0 = not and
+ 1 hash N1 of lnth 0 = not
+ 1 hash N2 of lnth 0 = not and
] filter ;
:: print-puzzle ( hash-array -- )
hash-array
[| hash |
- " " printf hash N1 of [ "%d " printf ] leach nl
- "+ " printf hash N2 of [ "%d " printf ] leach nl
- "----------------" printf nl
- " " printf hash N of [ "%d " printf ] leach nl nl
+ " " printf hash N1 of [ "%d " printf ] leach nl
+ "+ " printf hash N2 of [ "%d " printf ] leach nl
+ "----------------" printf nl
+ " " printf hash N of [ "%d " printf ] leach nl nl
] each ;
{ { H{ { X Tom } } } } [ { cato X } query ] unit-test
{
{
- H{ { X big } { Y a-big-cat } }
- H{ { X small } { Y a-small-cat } }
+ H{ { X big } { Y a-big-cat } }
+ H{ { X small } { Y a-small-cat } }
}
} [ { cato X Y } query ] unit-test
{
{ [ dup __ = ] [ drop proxy-var-for-'__' ] }
{ [ dup sequence? ] [ [ replace-'__' ] map ] }
{ [ dup tuple? ] [
- [ tuple-slots [ replace-'__' ] map ]
- [ class-of slots>tuple ] bi ] }
+ [ tuple-slots [ replace-'__' ] map ]
+ [ class-of slots>tuple ] bi ] }
[ ]
} cond ;
] when
] loop
] with-return
- bindings dup {
+ bindings dup {
[ empty? ]
[ first keys empty? ]
} 1|| [ drop success? ] [ >array ] if ;
d-env env-clear
f
] if
- ] [ f ] if
+ ] [ f ] if
] each-until
] if
] if ;
: build-loop-error ( error callstack -- )
fatal-error-body
- "build loop error"
- email-fatal ;
+ "build loop error"
+ email-fatal ;
: build-loop ( -- )
[
{ 0 0 } [ [ ] with-report ] must-infer-as
: verify-report ( -- )
- [ t ] [ "report" file-exists? ] unit-test
- [ ] [ "report" file>xml drop ] unit-test
- [ ] [ "report" delete-file ] unit-test ;
+ [ t ] [ "report" file-exists? ] unit-test
+ [ ] [ "report" file>xml drop ] unit-test
+ [ ] [ "report" delete-file ] unit-test ;
"builds" temp-file builds-dir [
[
{ 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } }
: axes ( a -- a' )
-
[ x>> ] [ y>> ] bi { 0.0 0.0 } <affine-transform> ;
+ [ x>> ] [ y>> ] bi { 0.0 0.0 } <affine-transform> ;
: a.v ( a v -- v )
[ [ x>> ] [ first ] bi* v*n ]
! This allows a set of partial derivatives each to be evaluated
! at the same point.
MACRO: duals>nweave ( n -- quot )
- dup dup dup
- '[
- [ [ epsilon-part>> ] _ napply ] _ nkeep
- [ ordinary-part>> ] _ napply _ nweave
+ dup dup dup
+ '[
+ [ [ epsilon-part>> ] _ napply ] _ nkeep
+ [ ordinary-part>> ] _ napply _ nweave
] ;
MACRO: chain-rule ( word -- e )
HELP: biweekly
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of two week periods in a year." } ;
HELP: daily-360
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of days in a 360-day year." } ;
HELP: daily-365
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of days in a 365-day year." } ;
HELP: monthly
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of months in a year." } ;
HELP: semimonthly
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
HELP: weekly
{ $values
- { "x" number }
- { "y" number }
+ { "x" number }
+ { "y" number }
}
{ $description "Divides a number by the number of weeks in a year." } ;
DEFER: basic
CONSTANT: literals
- H{ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
- { 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
- { 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
- { 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
- { 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
- { 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
- { 71 "soixante et onze" } { 80 "quatre-vingts" }
- { 81 "quatre-vingt-un" }
- { 100 "cent" } { 1000 "mille" } }
+ H{
+ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
+ { 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
+ { 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
+ { 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
+ { 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
+ { 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
+ { 71 "soixante et onze" } { 80 "quatre-vingts" }
+ { 81 "quatre-vingt-un" }
+ { 100 "cent" } { 1000 "mille" }
+ }
MEMO: units ( -- seq ) ! up to 10^99
{ "m" "b" "tr" "quadr" "quint" "sext" "sept" "oct"
{ title "Merging" }
{ pref-dim { 300 220 } }
}
- vertical <track>
+ vertical <track>
{ "From:" "To:" } f <model> f <model> 2array
[
[
] [
string>number "of %s" sprintf
] if* "runway %s visibility %s" sprintf
- ] dip " ft" " meters" ? append
+ ] dip " ft" " meters" ? append
] dip append ;
: (parse-weather) ( str -- str' )
<illusion> dup activate-model ;
: backtalk ( value object -- )
- [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
M: illusion update-model ( model -- )
[ [ value>> ] keep backtalk ] with-locked-model ;
"%" expect-and-span >string
[ take-tag-name >string ] dip-1up append
[ "%>" slice-til-string [ >string ] bi@ ] dip-2up
- <embedded-language> ;
+ <embedded-language> ;
: read-open-tag ( n string opening -- n' string tag )
[ take-tag-name ] dip-1up
] }
[ [ tag openstr2 n string ] dip long-opening-mismatch ]
} case
- ] ;
+ ] ;
: read-double-matched-paren ( n string tag ch -- n' string seq ) CHAR: ( read-double-matched ;
: read-double-matched-bracket ( n string tag ch -- n' string seq ) CHAR: [ read-double-matched ;
no-prefixes [ name>> ] map ;
CONSTANT: core-broken-vocabs
- {
+ {
"vocabs.loader.test.a"
"vocabs.loader.test.b"
"vocabs.loader.test.c"
: large-doc-prepare ( -- quot: ( i -- doc ) )
large-doc drop
- [ "x" DOC-LARGE clone [ set-at ] keep
- [ now "access-time" ] dip
- [ set-at ] keep ] ;
+ [
+ "x" DOC-LARGE clone [ set-at ] keep
+ [ now "access-time" ] dip
+ [ set-at ] keep
+ ] ;
: (insert) ( quot: ( i -- doc ) collection -- )
[ trial-size ] 2dip
'[ _ call( i -- doc ) [ _ ] dip
- result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
+ result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
[ [ * ] keep 1 range boa ] dip
: (insert-batch) ( quot: ( i -- doc ) collection -- )
[ trial-size batch-size [ / ] keep ] 2dip
'[ _ _ (prepare-batch) [ _ ] dip
- result get lasterror>> [ save ] [ save-unsafe ] if
+ result get lasterror>> [ save ] [ save-unsafe ] if
] each-integer ;
: bchar ( boolean -- char )
: find-range ( quot -- quot: ( -- ) )
drop
- [ trial-size batch-size /i
- collection-name
- trial-size 2 / "$gt" H{ } clone [ set-at ] keep
- [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
- "x" H{ } clone [ set-at ] keep
- '[ _ _ <query> (find) ] times ] ;
+ [
+ trial-size batch-size /i
+ collection-name
+ trial-size 2 / "$gt" H{ } clone [ set-at ] keep
+ [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
+ "x" H{ } clone [ set-at ] keep
+ '[ _ _ <query> (find) ] times
+ ] ;
: batch ( -- )
result [ t >>batch ] change ; inline
'[ <result> _ call( options -- time ) print-result ] with-scope ;
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
- '[ _ swap _
- '[ [ [ _ execute( -- quot ) ] dip
- [ execute( -- ) ] each _ execute( quot -- quot ) gc
- benchmark ] with-result ] each
- print-separator ] ;
+ '[
+ _ swap _
+ '[
+ [
+ [ _ execute( -- quot ) ] dip
+ [ execute( -- ) ] each _ execute( quot -- quot ) gc
+ benchmark
+ ] with-result
+ ] each
+ print-separator
+ ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
"Serialization Tests" print
check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
- [ mdb-connection get instance>> auth?
- [ perform-authentication ] when
- ] with-connection ; inline
+ [
+ mdb-connection get instance>> auth?
+ [ perform-authentication ] when
+ ] with-connection ; inline
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: split-host-str ( hoststr -- host port )
- ":" split [ first ] [ second string>number ] bi ; inline
+ ":" split [ first ] [ second string>number ] bi ; inline
: eval-ismaster-result ( node result -- )
- [
+ [
[ "ismaster" ] dip at dup string?
[ >integer 1 = ] when >>master? drop
- ] [
+ ] [
[ "remote" ] dip at
[ split-host-str <inet> f <mdb-node> >>remote ] when* drop
] 2bi ;
: check-node ( mdb node -- )
- [ <mdb-connection> &dispose ] dip
- [ [ open-connection ] [ 3drop f ] recover ] keep swap
- [ [ get-ismaster eval-ismaster-result ] with-connection ] [ drop ] if* ;
+ [ <mdb-connection> &dispose ] dip
+ [ [ open-connection ] [ 3drop f ] recover ] keep swap
+ [ [ get-ismaster eval-ismaster-result ] with-connection ] [ drop ] if* ;
: nodelist>table ( seq -- assoc )
- [ [ master?>> ] keep 2array ] map >hashtable ;
+ [ [ master?>> ] keep 2array ] map >hashtable ;
PRIVATE>
] recover ;
: mdb-close ( mdb-connection -- )
- [ [ dispose ] when* f ] change-handle drop ;
+ [ [ dispose ] when* f ] change-handle drop ;
M: mdb-connection dispose
- mdb-close ;
+ mdb-close ;
H{ } clone [ set-at ] keep ;
: <mdb> ( db host port -- mdb )
- <inet> t [ <mdb-node> ] keep
- H{ } clone [ set-at ] keep <mdb-db>
- [ verify-nodes ] keep ;
+ <inet> t [ <mdb-node> ] keep
+ H{ } clone [ set-at ] keep <mdb-db>
+ [ verify-nodes ] keep ;
GENERIC: create-collection ( name/collection -- )
: (ensure-collection) ( collection mdb-instance -- collection )
ensure-collection-map [ dup ] dip key?
- [ ] [ [ ensure-valid-collection-name ]
- [ create-collection ]
- [ ] tri ] if ;
+ [ ] [
+ [ ensure-valid-collection-name ]
+ [ create-collection ]
+ [ ] tri
+ ] if ;
: reserved-namespace? ( name -- ? )
[ "$cmd" = ] [ "system" head? ] bi or ;
: write-insert-message ( message -- )
[
- [ flags>> write-int32 ]
- [ collection>> write-cstring ]
- [ objects>> [ assoc>stream ] each ] tri
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ objects>> [ assoc>stream ] each ] tri
] (write-message) ; inline
: write-update-message ( message -- )
: write-killcursors-message ( message -- )
[
- [ flags>> write-int32 ]
- [ cursors#>> write-int32 ]
- [ cursors>> [ write-longlong ] each ] tri
+ [ flags>> write-int32 ]
+ [ cursors#>> write-int32 ]
+ [ cursors>> [ write-longlong ] each ] tri
] (write-message) ; inline
PRIVATE>
CONSTANT: MDB_COLLECTION_MAP "mongodb_collection_map"
MEMO: id-slot ( class -- slot )
- MDB_USER_KEY word-prop
- dup [ drop "_id" ] unless ;
+ MDB_USER_KEY word-prop
+ dup [ drop "_id" ] unless ;
PRIVATE>
: >toid ( object -- toid )
- [ id>> ] [ class-of id-slot ] bi <toid> ;
+ [ id>> ] [ class-of id-slot ] bi <toid> ;
M: mdb-persistent id>> ( object -- id )
- dup class-of id-slot reader-word execute( object -- id ) ;
+ dup class-of id-slot reader-word execute( object -- id ) ;
M: mdb-persistent id<< ( object value -- )
- over class-of id-slot writer-word execute( object value -- ) ;
+ over class-of id-slot writer-word execute( object value -- ) ;
PRIVATE>
: MDB_ADDON_SLOTS ( -- slots )
- { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
+ { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
: link-class ( collection class -- )
over classes>>
M: string <mdb-tuple-collection>
collection-map [ ] [ key? ] 2bi
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
- [ [ >>name ] keep ] dip set-at ] if ; inline
+ [ [ >>name ] keep ] dip set-at ] if ; inline
M: mdb-tuple-collection <mdb-tuple-collection> ;
M: mdb-collection <mdb-tuple-collection>
[ name>> <mdb-tuple-collection> ] keep
<PRIVATE
: mdbinfo>tuple-class ( tuple-info -- class )
- [ first ] keep second lookup-word ; inline
+ [ first ] keep second lookup-word ; inline
: tuple-instance ( tuple-info -- instance )
mdbinfo>tuple-class new ; inline
: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
- [ tuple-info tuple-instance dup
- <mirror> [ keys ] keep ] keep swap ; inline
+ [ tuple-info tuple-instance dup
+ <mirror> [ keys ] keep ] keep swap ; inline
: make-tuple ( assoc -- tuple )
- prepare-assoc>tuple
- '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
+ prepare-assoc>tuple
+ '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
: at+ ( value key assoc -- value )
2dup key?
[ assoc? not ] [ drop f ] if ; inline
: add-storable ( assoc ns toid -- )
- [ [ H{ } clone ] dip object-map get at+ ] dip
- swap set-at ; inline
+ [ [ H{ } clone ] dip object-map get at+ ] dip
+ swap set-at ; inline
: write-field? ( tuple key value -- ? )
- pick mdb-persistent? [
- { [ 2nip not ]
- [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
+ pick mdb-persistent?
+ [ { [ 2nip not ] [ drop transient-slot? ] } 3|| not ]
+ [ 3drop t ] if ; inline
TUPLE: cond-value value quot ;
CONSTRUCTOR: <cond-value> cond-value ( value quot -- cond-value ) ;
: write-mdb-persistent ( value quot -- value' )
- over [ call( tuple -- assoc ) ] dip
- [ [ tuple-collection name>> ] [ >toid ] bi ] keep
- [ add-storable ] dip
- [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
+ over [ call( tuple -- assoc ) ] dip
+ [ [ tuple-collection name>> ] [ >toid ] bi ] keep
+ [ add-storable ] dip
+ [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' )
- <cond-value> {
- { [ dup value>> mdb-special-value? ] [ value>> ] }
- { [ dup value>> mdb-persistent? ]
- [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
- { [ dup value>> data-tuple? ]
- [ [ value>> ] [ quot>> ] bi ( tuple -- assoc ) call-effect ] }
- { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
- [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
- [ value>> ]
- } cond ;
+ <cond-value> {
+ { [ dup value>> mdb-special-value? ] [ value>> ] }
+ { [ dup value>> mdb-persistent? ]
+ [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
+ { [ dup value>> data-tuple? ]
+ [ [ value>> ] [ quot>> ] bi ( tuple -- assoc ) call-effect ] }
+ { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
+ [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
+ [ value>> ]
+ } cond ;
: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
- swap ! m t q q a
- '[ _ 2over write-field?
- [ _ write-field swap _ set-at ]
- [ 2drop ] if
- ] assoc-each ;
+ swap ! m t q a
+ '[
+ _ 2over write-field?
+ [ _ write-field swap _ set-at ]
+ [ 2drop ] if
+ ] assoc-each ;
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
- H{ } clone swap [ <mirror> ] keep pick ; inline
+ H{ } clone swap [ <mirror> ] keep pick ; inline
: with-object-map ( quot: ( -- ) -- store-assoc )
- [ H{ } clone dup object-map ] dip with-variable ; inline
+ [ H{ } clone dup object-map ] dip with-variable ; inline
: (tuple>assoc) ( tuple -- assoc )
- [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
- over set-tuple-info ; inline
+ [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
+ over set-tuple-info ; inline
PRIVATE>
GENERIC: tuple>storable ( tuple -- storable )
: ensure-oid ( tuple -- tuple )
- dup id>> [ <oid> >>id ] unless ; inline
+ dup id>> [ <oid> >>id ] unless ; inline
M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
- '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
+ '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
M: mdb-persistent tuple>assoc ( tuple -- assoc )
- ensure-oid (tuple>assoc) ;
+ ensure-oid (tuple>assoc) ;
M: tuple tuple>assoc ( tuple -- assoc )
- (tuple>assoc) ;
+ (tuple>assoc) ;
M: tuple tuple>selector ( tuple -- assoc )
prepare-assoc [ tuple>selector ] write-tuple-fields ;
: assoc>tuple ( assoc -- tuple )
- dup assoc? [
+ dup assoc? [
[ dup tuple-info? [ make-tuple ] when ] ignore-errors
- ] when ; inline recursive
+ ] when ; inline recursive
[ MDB_TUPLE_INFO ] dip at ; inline
: set-tuple-info ( tuple assoc -- )
- [ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
+ [ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
: tuple-info? ( assoc -- ? )
- [ MDB_TUPLE_INFO ] dip key? ;
+ [ MDB_TUPLE_INFO ] dip key? ;
: ensure-table ( class -- )
tuple-collection
[ create-collection ]
- [ [ mdb-index-map values ] keep
- '[ _ name>> >>ns ensure-index ] each
+ [
+ [ mdb-index-map values ] keep
+ '[ _ name>> >>ns ensure-index ] each
] bi ;
: ensure-tables ( classes -- )
[ ensure-table ] each ;
: drop-table ( class -- )
- tuple-collection
- [ [ mdb-index-map values ] keep
- '[ _ name>> swap name>> drop-index ] each ]
- [ name>> drop-collection ] bi ;
+ tuple-collection
+ [ [ mdb-index-map values ] keep
+ '[ _ name>> swap name>> drop-index ] each ]
+ [ name>> drop-collection ] bi ;
: recreate-table ( class -- )
[ drop-table ]
GENERIC: id-selector ( object -- selector )
M: toid id-selector
- [ value>> ] [ key>> ] bi associate ; inline
+ [ value>> ] [ key>> ] bi associate ; inline
M: mdb-persistent id-selector
- >toid id-selector ;
+ >toid id-selector ;
: (save-tuples) ( collection assoc -- )
- swap '[ [ _ ] 2dip
- [ id-selector ] dip
- <update> >upsert update ] assoc-each ; inline
+ swap '[
+ [ _ ] 2dip
+ [ id-selector ] dip
+ <update> >upsert update
+ ] assoc-each ; inline
: prepare-tuple-query ( tuple/query -- query )
dup mdb-query-msg? [ tuple>query ] unless ;
update-tuple ;
: insert-tuple ( tuple -- )
- [ tuple-collection name>> ]
- [ tuple>assoc ] bi
- save ;
+ [ tuple-collection name>> ]
+ [ tuple>assoc ] bi
+ save ;
: delete-tuple ( tuple -- )
- [ tuple-collection name>> ] keep
- id-selector <delete> delete ;
+ [ tuple-collection name>> ] keep
+ id-selector <delete> delete ;
: delete-tuples ( seq -- )
[ delete-tuple ] each ;
: tuple>query ( tuple -- query )
- [ tuple-collection name>> ] keep
- tuple>selector <query> ;
+ [ tuple-collection name>> ] keep
+ tuple>selector <query> ;
: select-tuple ( tuple/query -- tuple/f )
- prepare-tuple-query
- find-one [ assoc>tuple ] [ f ] if* ;
+ prepare-tuple-query
+ find-one [ assoc>tuple ] [ f ] if* ;
: select-tuples ( tuple/query -- cursor tuples/f )
- prepare-tuple-query
- find [ assoc>tuple ] map ;
+ prepare-tuple-query
+ find [ assoc>tuple ] map ;
: select-all-tuples ( tuple/query -- tuples )
- prepare-tuple-query
- find-all [ assoc>tuple ] map ;
+ prepare-tuple-query
+ find-all [ assoc>tuple ] map ;
: count-tuples ( tuple/query -- n )
- dup mdb-query-msg? [ tuple>query ] unless count ;
+ dup mdb-query-msg? [ tuple>query ] unless count ;
FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr )
FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr )
FUNCTION: SQLRETURN SQLGetDiagRec (
- SQLSMALLINT HandleType,
- SQLHANDLE Handle,
- SQLSMALLINT RecNumber,
- SQLCHAR* SQLState,
- SQLINTEGER* NativeErrorPtr,
- SQLCHAR* MessageText,
- SQLSMALLINT BufferLength,
- SQLSMALLINT* TextLengthPtr )
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle,
+ SQLSMALLINT RecNumber,
+ SQLCHAR* SQLState,
+ SQLINTEGER* NativeErrorPtr,
+ SQLCHAR* MessageText,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT* TextLengthPtr )
: alloc-handle ( type parent -- handle )
f void* <ref> [ SQLAllocHandle ] keep swap succeeded? [
sum pickd = [ next-pq 2dup abc (ptriplet) ] unless ;
: ptriplet ( target -- triplet )
- 3 1 { 3 4 5 } (ptriplet) abc nip ;
+ 3 1 { 3 4 5 } (ptriplet) abc nip ;
PRIVATE>
sieve get length 1 - over <range> ;
: increment-counts ( n -- )
- multiples [ sieve get [ 1 + ] change-nth ] each ;
+ multiples [ sieve get [ 1 + ] change-nth ] each ;
: prime-tau-upto ( limit -- seq )
dup initialize-sieve 2 swap [a..b) [
] each sieve get ;
: consecutive-under ( limit m -- n/f )
- [ prime-tau-upto ] [ dup <repetition> ] bi* subseq-index ;
+ [ prime-tau-upto ] [ dup <repetition> ] bi* subseq-index ;
PRIVATE>
: save-family ( family -- )
dup family-count get at 8 = [ large-families get adjoin ] [ drop ] if ;
: increment-family ( family -- )
- family-count get inc-at ;
+ family-count get inc-at ;
: handle-family ( family -- )
[ increment-family ] [ save-family ] bi ;
PRIVATE>
: euler070 ( -- answer )
- likely-prime-factors 2 all-combinations [ n-and-phi ] map
- [ fit-requirements? ] filter minimum-ratio ;
+ likely-prime-factors 2 all-combinations [ n-and-phi ] map
+ [ fit-requirements? ] filter minimum-ratio ;
! [ euler070 ] 100 ave-time
! 379 ms ave run time - 1.15 SD (100 trials)
PRIVATE>
: euler099 ( -- answer )
- source-099 solve ;
+ source-099 solve ;
! [ euler099 ] 100 ave-time
! 16 ms ave run timen - 1.67 SD (100 trials)
[ length swap - 1 - ] keep ?nth 0 or ;
: next ( colortile seq -- )
- [ nth* ] [ last + ] [ push ] tri ;
+ [ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
{ { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
{ { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
[ [ dup length <iota> [ pick-sheet ] with map-sum ] [ sum ] bi / ]
- } case ] cache ;
+ } case ] cache ;
: euler151 ( -- answer )
[
! (D) Czech:
{
- "\u{0050}\u{0072}\u{006F}\u{010D}\u{0070}\u{0072}\u{006F}\u{0073}\u{0074}\u{011B}\u{006E}\u{0065}\u{006D}\u{006C}\u{0075}\u{0076}\u{00ED}\u{010D}\u{0065}\u{0073}\u{006B}\u{0079}"
- "Proprostnemluvesky-uyb24dma41a"
+ "\u{0050}\u{0072}\u{006F}\u{010D}\u{0070}\u{0072}\u{006F}\u{0073}\u{0074}\u{011B}\u{006E}\u{0065}\u{006D}\u{006C}\u{0075}\u{0076}\u{00ED}\u{010D}\u{0065}\u{0073}\u{006B}\u{0079}"
+ "Proprostnemluvesky-uyb24dma41a"
}
! (E) Hebrew:
! (N) Hello-Another-Way-<sorezore><no><basho>
{
"\u{0048}\u{0065}\u{006C}\u{006C}\u{006F}\u{002D}\u{0041}\u{006E}\u{006F}\u{0074}\u{0068}\u{0065}\u{0072}\u{002D}\u{0057}\u{0061}\u{0079}\u{002D}\u{305D}\u{308C}\u{305E}\u{308C}\u{306E}\u{5834}\u{6240}"
- "Hello-Another-Way--fc4qua05auwb3674vfr0b"
+ "Hello-Another-Way--fc4qua05auwb3674vfr0b"
}
! (O) <hitotsu><yane><no><shita>2
! (P) Maji<de>Koi<suru>5<byou><mae>
{
- "\u{004D}\u{0061}\u{006A}\u{0069}\u{3067}\u{004B}\u{006F}\u{0069}\u{3059}\u{308B}\u{0035}\u{79D2}\u{524D}"
- "MajiKoi5-783gue6qz075azm5e"
+ "\u{004D}\u{0061}\u{006A}\u{0069}\u{3067}\u{004B}\u{006F}\u{0069}\u{3059}\u{308B}\u{0035}\u{79D2}\u{524D}"
+ "MajiKoi5-783gue6qz075azm5e"
}
! (Q) <pafii>de<runba>
{
- "\u{30D1}\u{30D5}\u{30A3}\u{30FC}\u{0064}\u{0065}\u{30EB}\u{30F3}\u{30D0}"
- "de-jg4avhby1noc0d"
+ "\u{30D1}\u{30D5}\u{30A3}\u{30FC}\u{0064}\u{0065}\u{30EB}\u{30F3}\u{30D0}"
+ "de-jg4avhby1noc0d"
}
! (R) <sono><supiido><de>
! (S) -> $1.00 <-
{
- "\u{002D}\u{003E}\u{0020}\u{0024}\u{0031}\u{002E}\u{0030}\u{0030}\u{0020}\u{003C}\u{002D}"
+ "\u{002D}\u{003E}\u{0020}\u{0024}\u{0031}\u{002E}\u{0030}\u{0030}\u{0020}\u{003C}\u{002D}"
"-> $1.00 <--"
}
} [
tri
bary [ first3
"Barycenter: %3.2f %3.2f %3.2f" sprintf 10 ypos 45 + 10 BLACK draw-text
- ] when*
+ ] when*
] [ drop ] if
"Use Mouse to Move Camera" 10 screen-height 20 - 10 GRAY draw-text
: set-completion ( quot -- )
[
- '[
+ '[
[ @ [ utf8 malloc-string ] [ f ] if* ]
readline.ffi:rl_compentry_func_t
] ( -- alien ) define-temp
animated-label
H{
{ T{ button-down } [ [ not ] change-reversed drop ] }
- } set-gestures
+ } set-gestures
M: animated-label graft*
[ [ [ model>> ] [ reversed>> ] bi update-model ] curry 400 milliseconds every ] keep
} cond ;
: add-to-score ( arr -- score )
- <score> [ bull? [ inc-bulls ] [ inc-cows ] if ] reduce ;
+ <score> [ bull? [ inc-bulls ] [ inc-cows ] if ] reduce ;
: check-win ( score -- ? ) bulls>> 4 = ;
! Output a random integer 1..5.
: dice5 ( -- x )
- 5 [1..b] random ;
+ 5 [1..b] random ;
! Output a random integer 1..7 using dice5 as randomness source.
: dice7 ( -- x )
'[ _ [ _ add-to-file-list ] change-at ] each ;
: (index-files) ( files index -- )
- [ [ [ file-words ] keep ] dip swap add-to-index ] curry each ;
+ [ [ [ file-words ] keep ] dip swap add-to-index ] curry each ;
: index-files ( files -- index )
H{ } clone [ (index-files) ] keep ;
"Example: metronome " write print-defaults flush ;
: metronome-main ( -- )
- [ [ metronome-cmdline metronome-ui ] [ drop metronome-usage 1 exit ] recover ] with-ui ;
+ [ [ metronome-cmdline metronome-ui ] [ drop metronome-usage 1 exit ] recover ] with-ui ;
MAIN: metronome-main
:: safe? ( board q -- ? )
[let q board nth :> x
- q <iota> [
- x swap
- [ board nth ] keep
- q swap -
- [ + = not ]
- [ - = not ] 3bi and
- ] all?
+ q <iota> [
+ x swap
+ [ board nth ] keep
+ q swap -
+ [ + = not ]
+ [ - = not ] 3bi and
+ ] all?
] ;
: solution? ( board -- ? )
:: almost-ack ( quot -- quot )
[
{
- { [ over zero? ] [ nip 1 + ] }
- { [ dup zero? ] [ [ 1 - ] [ drop 1 ] bi* quot call ] }
- [ [ drop 1 - ] [ 1 - quot call ] 2bi quot call ]
+ { [ over zero? ] [ nip 1 + ] }
+ { [ dup zero? ] [ [ 1 - ] [ drop 1 ] bi* quot call ] }
+ [ [ drop 1 - ] [ 1 - quot call ] 2bi quot call ]
} cond
] ;
HELP: subseq*
{ $values
- { "from" integer } { "to" integer } { "seq" sequence } { "subseq" sequence } }
+ { "from" integer } { "to" integer } { "seq" sequence } { "subseq" sequence } }
{ $description "Outputs a new sequence using positions relative to one or both ends of the sequence. Positive values describes offsets relative to the start of the sequence, negative values relative to the end. Values of " { $link f } " for " { $snippet "from" } " indicate the beginning of the sequence, while an " { $link f } " for " { $snippet "to" } " indicates the end of the sequence." }
{ $notes "Both " { $snippet "from" } " and " { $snippet "to" } " can be safely set to values outside the length of the sequence. Also, " { $snippet "from" } " can safely reference a smaller or greater index position than " { $snippet "to" } "." }
{ $examples
HELP: start-all
{ $values
- { "seq" sequence } { "subseq" sequence } { "indices" sequence } }
+ { "seq" sequence } { "subseq" sequence } { "indices" sequence } }
{ $description "Outputs the starting indices of the non-overlapping occurrences of " { $snippet "subseq" } " in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: prettyprint sequences.extras ;"
] if ; inline
: unsurround ( newseq seq2 seq3 -- seq1 )
- [ ?head drop ] [ ?tail drop ] bi* ;
+ [ ?head drop ] [ ?tail drop ] bi* ;
: >string-list ( seq -- seq' )
[ "\"" 1surround ] map "," join ;
[ [ dup ] compose [ ] ] dip produce-as nip ; inline
: loop>array ( ... quot: ( ... -- ... obj/f ) -- ... array )
- { } loop>sequence ; inline
+ { } loop>sequence ; inline
: zero-loop>sequence ( ... quot: ( ... n -- ... obj/f ) exemplar -- ... seq )
[ 0 ] [ '[ _ keep 1 + swap ] ] [ loop>sequence ] tri* nip ; inline
{ 2 1 } [
T{ ast-block f
- { "a" "b" }
- {
- T{ ast-message-send f
- T{ ast-name f "a" }
- "+"
- { T{ ast-name f "b" } }
- }
- }
+ { "a" "b" }
+ {
+ T{ ast-message-send f
+ T{ ast-name f "a" }
+ "+"
+ { T{ ast-name f "b" } }
+ }
+ }
} test-inference
] unit-test
{ 3 1 } [
T{ ast-block f
- { "a" "b" "c" }
- {
- T{ ast-assignment f
- T{ ast-name f "a" }
- T{ ast-message-send f
- T{ ast-name f "c" }
- "+"
- { T{ ast-name f "b" } }
- }
- }
- T{ ast-message-send f
- T{ ast-name f "b" }
- "blah:"
- { 123.456 }
- }
- T{ ast-return f T{ ast-name f "c" } }
- }
+ { "a" "b" "c" }
+ {
+ T{ ast-assignment f
+ T{ ast-name f "a" }
+ T{ ast-message-send f
+ T{ ast-name f "c" }
+ "+"
+ { T{ ast-name f "b" } }
+ }
+ }
+ T{ ast-message-send f
+ T{ ast-name f "b" }
+ "blah:"
+ { 123.456 }
+ }
+ T{ ast-return f T{ ast-name f "c" } }
+ }
} test-inference
] unit-test
{ 0 1 } [
T{ ast-block f
- { }
- { }
- {
- T{ ast-message-send
- { receiver 1 }
- { selector "to:do:" }
- { arguments
- {
- 10
- T{ ast-block
- { arguments { "i" } }
- { body
- {
- T{ ast-message-send
- { receiver
- T{ ast-name { name "i" } }
+ { }
+ { }
+ {
+ T{ ast-message-send
+ { receiver 1 }
+ { selector "to:do:" }
+ { arguments
+ {
+ 10
+ T{ ast-block
+ { arguments { "i" } }
+ { body
+ {
+ T{ ast-message-send
+ { receiver T{ ast-name { name "i" } } }
+ { selector "print" }
+ }
}
- { selector "print" }
- }
- }
- }
+ }
+ }
}
}
- }
- }
+ }
}
} test-inference
] unit-test
{ "a" } [
T{ ast-block f
- { }
- { }
- { { T{ ast-block { body { "a" } } } } }
+ { }
+ { }
+ { { T{ ast-block { body { "a" } } } } }
} test-compilation call first call
] unit-test
{
T{ ast-block
- { arguments { "i" } }
- { body
- {
- T{ ast-message-send
- { receiver T{ ast-name { name "i" } } }
- { selector "print" }
- }
- }
- }
+ { arguments { "i" } }
+ { body
+ {
+ T{ ast-message-send
+ { receiver T{ ast-name { name "i" } } }
+ { selector "print" }
+ }
+ }
+ }
}
}
[ "[ :i | i print ]" test-Literal ] unit-test
{
T{ ast-block
- { body { 5 self } }
+ { body { 5 self } }
}
}
[ "[5. self]" test-Literal ] unit-test
{
T{ ast-message-send
- { receiver
- T{ ast-message-send
- { receiver
- T{ ast-message-send
- { receiver 1 }
- { selector "<" }
- { arguments { 10 } }
- }
- }
- { selector "ifTrue:ifFalse:" }
- { arguments
- {
- T{ ast-block { body { "HI" } } }
- T{ ast-block { body { "BYE" } } }
- }
+ { receiver
+ T{ ast-message-send
+ { receiver
+ T{ ast-message-send
+ { receiver 1 }
+ { selector "<" }
+ { arguments { 10 } }
+ }
+ }
+ { selector "ifTrue:ifFalse:" }
+ { arguments
+ {
+ T{ ast-block { body { "HI" } } }
+ T{ ast-block { body { "BYE" } } }
+ }
+ }
}
- }
- }
- { selector "print" }
+ }
+ { selector "print" }
}
}
[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
{
T{ ast-cascade
- { receiver 12 }
- { messages
- {
- T{ ast-message f "sqrt" }
- T{ ast-message f "+" { 2 } }
- }
- }
+ { receiver 12 }
+ { messages
+ {
+ T{ ast-message f "sqrt" }
+ T{ ast-message f "+" { 2 } }
+ }
+ }
}
}
[ "12 sqrt; + 2" test-Expression ] unit-test
{
T{ ast-cascade
- { receiver T{ ast-message-send f 12 "sqrt" } }
- { messages
- {
- T{ ast-message f "+" { 1 } }
- T{ ast-message f "+" { 2 } }
- }
+ { receiver T{ ast-message-send f 12 "sqrt" } }
+ { messages
+ {
+ T{ ast-message f "+" { 1 } }
+ T{ ast-message f "+" { 2 } }
+ }
}
}
}
{
T{ ast-cascade
- { receiver T{ ast-message-send f 12 "squared" } }
- { messages
- {
- T{ ast-message f "to:" { 100 } }
- T{ ast-message f "sqrt" }
- }
+ { receiver T{ ast-message-send f 12 "squared" } }
+ { messages
+ {
+ T{ ast-message f "to:" { 100 } }
+ T{ ast-message f "sqrt" }
+ }
}
}
}
{
T{ ast-message-send
- { receiver
- T{ ast-message-send
- { receiver { T{ ast-block { body { "a" } } } } }
- { selector "at:" }
- { arguments { 0 } }
- }
- }
- { selector "value" }
+ { receiver
+ T{ ast-message-send
+ { receiver { T{ ast-block { body { "a" } } } } }
+ { selector "at:" }
+ { arguments { 0 } }
+ }
+ }
+ { selector "value" }
}
}
[ "(#(['a']) at: 0) value" test-Expression ] unit-test
uchar* c, ulonglong clen,
uchar* ad, ulonglong adlen )
FUNCTION: void crypto_secretstream_xchacha20poly1305_rekey (
- crypto_secretstream_xchacha20poly1305_state* state )
+ crypto_secretstream_xchacha20poly1305_state* state )
! sodium_runtime_H
FUNCTION: int sodium_runtime_has_neon ( )
HELP: <spider>
{ $values
- { "base" "a string or url" }
- { "spider" spider } }
+ { "base" "a string or url" }
+ { "spider" spider } }
{ $description "Creates a new web spider with a given base url." } ;
HELP: run-spider
{ $values
- { "spider" spider } }
+ { "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
ARTICLE: "spider-tutorial" "Spider tutorial"
<PRIVATE
: aligned-slices ( seq -- head tail )
- dup length 0xf unmask cut-slice ; inline
+ dup length 0xf unmask cut-slice ; inline
: count-characters ( -- n )
0 [ length + ] each-block-slice ; inline
: count-lines ( -- n )
0 [
- aligned-slices [
- uchar-16 cast-array swap
- [ CHAR: \n uchar-16-with v= vcount + >fixnum ] reduce
- ] [ [ CHAR: \n = ] count + >fixnum ] bi*
+ aligned-slices [
+ uchar-16 cast-array swap
+ [ CHAR: \n uchar-16-with v= vcount + >fixnum ] reduce
+ ] [ [ CHAR: \n = ] count + >fixnum ] bi*
] each-block-slice ; inline
: wc-stdin ( -- n )
{ V{ { 10 10 } { 15 10 } { 20 20 }
- { 15 20 } { 30 30 } { 35 30 }
+ { 15 20 } { 30 30 } { 35 30 }
} } [
TREE{ { 20 20 } { 10 10 } { 30 30 } } clone V{ } clone [
dupd 6 [ [
to-key node right>> node-right?
[ end-comparator (node>subalist-right) ]
[
- [ from-key ] 2dip start-comparator
- end-comparator (node>subalist)
+ [ from-key ] 2dip start-comparator
+ end-comparator (node>subalist)
] if
] when
] when ; inline recursive
{ blogs "new-post" } >>template
+ <protected>
"make a new blog post" >>description ;
: authorize-author ( author -- )
"author" value posts-by-url <redirect>
] >>submit
+ <protected>
"delete a blog post" >>description ;
: <delete-author-action> ( -- action )
"author" value posts-by-url <redirect>
] >>submit
+ <protected>
"delete a blog post" >>description ;
: validate-comment ( -- )
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
+ <protected>
"make a comment" >>description ;
: <delete-comment-action> ( -- action )
URL" $wiki" <redirect>
] >>submit
+ <protected>
"delete wiki articles" >>description
{ can-delete-wiki-articles? } >>capabilities ;
: reamining-chars ( game -- chars )
[ secret-word>> ] [ guesses>> ] bi [
- guess>chars
+ guess>chars
] with map concat members
[ background of ] assoc-map
[ drop ] collect-value-by
{ style yaml_mapping_style_t }
;
UNION-STRUCT: node_data
- { scalar scalar_node_data }
- { sequence sequence_node_data }
- { mapping mapping_node_data }
+ { scalar scalar_node_data }
+ { sequence sequence_node_data }
+ { mapping mapping_node_data }
;
STRUCT: yaml_node_t
H{ { "x" 0 } { "y" 2 } } :> LEFT
H{ { "r" 10 } } :> BIG
H{ { "r" 1 } } :> SMALL
- {
- CENTER
- LEFT
- BIG
- SMALL
- H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
- H{ { T{ yaml-merge } CENTER } { "r" 10 } { "label" "center/big" } }
- H{ { T{ yaml-merge } { CENTER BIG } } { "label" "center/big" } }
- H{ { T{ yaml-merge } { BIG LEFT SMALL } } { "x" 1 } { "label" "center/big" } }
-} ;
+ {
+ CENTER
+ LEFT
+ BIG
+ SMALL
+ H{ { "x" 1 } { "y" 2 } { "r" 10 } { "label" "center/big" } }
+ H{ { T{ yaml-merge } CENTER } { "r" 10 } { "label" "center/big" } }
+ H{ { T{ yaml-merge } { CENTER BIG } } { "label" "center/big" } }
+ H{ { T{ yaml-merge } { BIG LEFT SMALL } } { "x" 1 } { "label" "center/big" } }
+ } ;
CONSTANT: construct-merge-str "---
- &CENTER { x: 1, 'y': 2 }
${ construct-value-unsafe-obj } [ $ construct-value-unsafe-obj >yaml-docs yaml-docs> ] unit-test
${ construct-value-safe-obj } [
$ construct-value-str yaml-docs> [
- dup "link with" swap [ [ scalar-value ] map ] change-at
+ dup "link with" swap [ [ scalar-value ] map ] change-at
] map
] unit-test
] with-variable
] if
] with-destructors
done [ 2drop ] [
- [ [ parser event ] dip next-complex-value ] unless ,
+ [ [ parser event ] dip next-complex-value ] unless ,
] if
] until
] { } make ;
[ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
M: assoc (deref-aliases)
- [ [ (deref-aliases) ] bi-curry@ bi ] withd assoc-map! ;
+ [ [ (deref-aliases) ] bi-curry@ bi ] withd assoc-map! ;
: merge-values ( seq -- assoc )
reverse [ ] [ assoc-union ] map-reduce ;
>string " " split [ "=" split1 ] H{ } map>assoc ;
: find-metadata ( lines type -- metadata i )
- [ '[ _ head? ] find ] keep ?head drop parse-metadata swap ;
+ [ '[ _ head? ] find ] keep ?head drop parse-metadata swap ;
PRIVATE>
+new-group+ >>group ;
: zealot-test-commands ( path -- )
- [
+ [
32 <iota> [
load-and-test-command
] map [ try-process ] parallel-each
- ] with-directory ;
+ ] with-directory ;
: zealot-test-commands-old ( path -- )
[
{
T{ raw-zone
- { name "EST" }
- { gmt-offset "-5:00" }
- { rules/save "-" }
- { format "EST" }
- { until { } }
+ { name "EST" }
+ { gmt-offset "-5:00" }
+ { rules/save "-" }
+ { format "EST" }
+ { until { } }
}
} [
"EST" find-zone
projects / factor.git / commitdiff