Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
5515c7aacb
|
|
@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
|
|||
|
||||
HELP: load-library
|
||||
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
|
||||
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
|
||||
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
|
||||
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
|
||||
|
||||
HELP: add-library
|
||||
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
|
||||
|
|
@ -211,8 +210,9 @@ $nl
|
|||
ARTICLE: "alien-callback" "Calling Factor from C"
|
||||
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
|
||||
{ $subsection alien-callback }
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
{ $subsection "alien-callback-gc" } ;
|
||||
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
{ $subsection "alien-callback-gc" }
|
||||
{ $see-also "byte-arrays-gc" } ;
|
||||
|
||||
ARTICLE: "dll.private" "DLL handles"
|
||||
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
|
||||
|
|
@ -291,7 +291,7 @@ $nl
|
|||
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
|
||||
$nl
|
||||
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
|
||||
{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
|
||||
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
|
||||
{ $subsection "loading-libs" }
|
||||
{ $subsection "alien-invoke" }
|
||||
{ $subsection "alien-callback" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: alien.tests
|
||||
USING: alien alien.accessors byte-arrays arrays kernel
|
||||
kernel.private namespaces tools.test sequences libc math system
|
||||
prettyprint layouts ;
|
||||
USING: alien alien.accessors alien.syntax byte-arrays arrays
|
||||
kernel kernel.private namespaces tools.test sequences libc math
|
||||
system prettyprint layouts ;
|
||||
|
||||
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
||||
|
||||
|
|
@ -68,3 +68,7 @@ cell 8 = [
|
|||
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
|
||||
|
||||
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
|
||||
|
||||
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
|
||||
|
||||
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math namespaces sequences system
|
||||
kernel.private tuples bit-arrays byte-arrays float-arrays ;
|
||||
kernel.private tuples bit-arrays byte-arrays float-arrays
|
||||
arrays ;
|
||||
IN: alien
|
||||
|
||||
! Some predicate classes used by the compiler for optimization
|
||||
|
|
@ -57,7 +58,7 @@ TUPLE: library path abi dll ;
|
|||
over dup [ dlopen ] when \ library construct-boa ;
|
||||
|
||||
: load-library ( name -- dll )
|
||||
library library-dll ;
|
||||
library dup [ library-dll ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
|
|
|
|||
|
|
@ -158,6 +158,19 @@ HELP: define-out
|
|||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||
$nl
|
||||
"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
|
||||
{ $list
|
||||
"the C function returns"
|
||||
"the C function calls Factor code via a callback"
|
||||
}
|
||||
"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
|
||||
$nl
|
||||
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
|
||||
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
|
||||
|
||||
ARTICLE: "c-out-params" "Output parameters in C"
|
||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||
$nl
|
||||
|
|
@ -229,13 +242,11 @@ $nl
|
|||
{ $subsection <c-object> }
|
||||
{ $subsection <c-array> }
|
||||
{ $warning
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
|
||||
$nl
|
||||
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
|
||||
{ $see-also "c-arrays" } ;
|
||||
|
||||
ARTICLE: "malloc" "Manual memory management"
|
||||
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
|
||||
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
|
||||
$nl
|
||||
"Allocating a C datum with a fixed address:"
|
||||
{ $subsection malloc-object }
|
||||
|
|
@ -245,8 +256,6 @@ $nl
|
|||
{ $subsection malloc }
|
||||
{ $subsection calloc }
|
||||
{ $subsection realloc }
|
||||
"The return value of the above three words must always be checked for a memory allocation failure:"
|
||||
{ $subsection check-ptr }
|
||||
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||
{ $subsection free }
|
||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||
|
|
@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
|
|||
{ $subsection string>u16-alien }
|
||||
{ $subsection malloc-char-string }
|
||||
{ $subsection malloc-u16-string }
|
||||
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
|
||||
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
|
||||
{ $subsection alien>char-string }
|
||||
{ $subsection alien>u16-string } ;
|
||||
{ $subsection alien>u16-string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
$nl
|
||||
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
|
||||
{ $subsection "c-types-specs" }
|
||||
{ $subsection "c-byte-arrays" }
|
||||
{ $subsection "malloc" }
|
||||
{ $subsection "c-strings" }
|
||||
{ $subsection "c-arrays" }
|
||||
{ $subsection "c-out-params" }
|
||||
"Important guidelines for passing data in byte arrays:"
|
||||
{ $subsection "byte-arrays-gc" }
|
||||
"C-style enumerated types are supported:"
|
||||
{ $subsection POSTPONE: C-ENUM: }
|
||||
"C types can be aliased for convenience and consitency with native library documentation:"
|
||||
|
|
|
|||
|
|
@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
|
|||
r> add*
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien )
|
||||
binary file-contents malloc-byte-array ;
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents dup malloc-byte-array swap length ;
|
||||
|
||||
[
|
||||
[ alien-cell ]
|
||||
|
|
|
|||
|
|
@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
|||
|
||||
! Hack; if we're on ARM, we probably don't have much RAM, so
|
||||
! skip this test.
|
||||
cpu "arm" = [
|
||||
[ "testing" ] [
|
||||
"testing" callback-5a callback_test_1
|
||||
] unit-test
|
||||
] unless
|
||||
! cpu "arm" = [
|
||||
! [ "testing" ] [
|
||||
! "testing" callback-5a callback_test_1
|
||||
! ] unit-test
|
||||
! ] unless
|
||||
|
||||
: callback-6
|
||||
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ PRIVATE>
|
|||
>r >r swapd roll indirect-quot r> r>
|
||||
-rot define-declared ;
|
||||
|
||||
: DLL" skip-blank parse-string dlopen parsed ; parsing
|
||||
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
||||
|
||||
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ crossref off
|
|||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
H{ } clone dictionary set
|
||||
H{ } clone changed-words set
|
||||
H{ } clone root-cache set
|
||||
|
||||
! Trivial recompile hook. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
|
|
@ -87,11 +88,7 @@ call
|
|||
"words.private"
|
||||
"vectors"
|
||||
"vectors.private"
|
||||
} [
|
||||
dup find-vocab-root swap create-vocab
|
||||
[ set-vocab-root ] keep
|
||||
f swap set-vocab-source-loaded?
|
||||
] each
|
||||
} [ create-vocab drop ] each
|
||||
|
||||
H{ } clone source-files set
|
||||
H{ } clone class<map set
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
|
|||
"listener" vocab
|
||||
[ restarts. vocab-main execute ]
|
||||
[ die ] if*
|
||||
1 exit
|
||||
] recover
|
||||
] [
|
||||
"Cannot find " write write "." print
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ SYMBOL: bootstrap-time
|
|||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||
seq-diff
|
||||
[ "bootstrap." swap append require ] each ;
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
: compile-remaining ( -- )
|
||||
"Compiling remaining words..." print flush
|
||||
|
|
|
|||
|
|
@ -3,9 +3,7 @@
|
|||
USING: words sequences vocabs kernel ;
|
||||
IN: bootstrap.syntax
|
||||
|
||||
"syntax" create-vocab
|
||||
"resource:core" over set-vocab-root
|
||||
f swap set-vocab-source-loaded?
|
||||
"syntax" create-vocab drop
|
||||
|
||||
{
|
||||
"!"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien arrays definitions generic assocs hashtables io
|
||||
kernel math namespaces parser prettyprint sequences strings
|
||||
tools.test vectors words quotations classes io.streams.string
|
||||
tools.test vectors words quotations classes
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units ;
|
||||
IN: classes.tests
|
||||
|
|
@ -28,6 +28,8 @@ TUPLE: second-one ;
|
|||
UNION: both first-one union-class ;
|
||||
|
||||
[ t ] [ both tuple classes-intersect? ] unit-test
|
||||
[ null ] [ vector virtual-sequence class-and ] unit-test
|
||||
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [ \ fixnum \ integer class< ] unit-test
|
||||
[ t ] [ \ fixnum \ fixnum class< ] unit-test
|
||||
|
|
@ -61,10 +63,6 @@ UNION: c a b ;
|
|||
UNION: bah fixnum alien ;
|
||||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
||||
! Test redefinition of classes
|
||||
UNION: union-1 fixnum float ;
|
||||
|
||||
|
|
@ -178,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
|
|||
|
||||
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
|
||||
|
||||
USE: io.streams.string
|
||||
|
||||
2 [
|
||||
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||
|
||||
|
|
@ -222,3 +222,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
|||
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||
|
||||
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ PREDICATE: class union-class
|
|||
drop [ drop f ]
|
||||
] [
|
||||
unclip first "predicate" word-prop swap
|
||||
[ >r "predicate" word-prop [ dup ] swap append r> ]
|
||||
[ >r "predicate" word-prop [ dup ] prepend r> ]
|
||||
assoc-map alist>quot
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ M: hashtable hashcode*
|
|||
|
||||
: hash-case-quot ( default assoc -- quot )
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append ;
|
||||
[ dup hashcode >fixnum ] prepend ;
|
||||
|
||||
: contiguous-range? ( keys -- from to ? )
|
||||
dup [ fixnum? ] all? [
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@ splitting io.files ;
|
|||
|
||||
: run-bootstrap-init ( -- )
|
||||
"user-init" get [
|
||||
home ".factor-boot-rc" path+ ?run-file
|
||||
home ".factor-boot-rc" append-path ?run-file
|
||||
] when ;
|
||||
|
||||
: run-user-init ( -- )
|
||||
"user-init" get [
|
||||
home ".factor-rc" path+ ?run-file
|
||||
home ".factor-rc" append-path ?run-file
|
||||
] when ;
|
||||
|
||||
: cli-var-param ( name value -- ) swap set-global ;
|
||||
|
|
|
|||
|
|
@ -385,7 +385,7 @@ cell 8 = [
|
|||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||
|
||||
: xword-def word-def [ { fixnum } declare ] swap append ;
|
||||
: xword-def word-def [ { fixnum } declare ] prepend ;
|
||||
|
||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@ M: check-closed summary
|
|||
drop "Attempt to perform I/O on closed stream" ;
|
||||
|
||||
M: check-method summary
|
||||
drop "Invalid parameters for define-method" ;
|
||||
drop "Invalid parameters for create-method" ;
|
||||
|
||||
M: check-tuple summary
|
||||
drop "Invalid class for define-constructor" ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: definitions.tests
|
||||
USING: tools.test generic kernel definitions sequences
|
||||
compiler.units ;
|
||||
compiler.units words ;
|
||||
|
||||
TUPLE: combination-1 ;
|
||||
|
||||
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
|
||||
M: combination-1 perform-combination 2drop [ ] ;
|
||||
|
||||
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ SYMBOL: generic-1
|
|||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
[ ] object \ generic-1 define-method
|
||||
object \ generic-1 create-method [ ] define
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ $nl
|
|||
{ $subsection define-generic }
|
||||
{ $subsection define-simple-generic }
|
||||
"Methods can be added to existing generic words:"
|
||||
{ $subsection define-method }
|
||||
{ $subsection create-method }
|
||||
"Method definitions can be looked up:"
|
||||
{ $subsection method }
|
||||
{ $subsection methods }
|
||||
|
|
@ -123,7 +123,7 @@ HELP: method
|
|||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." } ;
|
||||
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
{ method create-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
|
||||
|
|
@ -140,16 +140,17 @@ HELP: order
|
|||
HELP: check-method
|
||||
{ $values { "class" class } { "generic" generic } }
|
||||
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
|
||||
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
|
||||
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
|
||||
|
||||
HELP: with-methods
|
||||
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
|
||||
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: define-method
|
||||
{ $values { "quot" quotation } { "class" class } { "generic" generic } }
|
||||
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
|
||||
HELP: create-method
|
||||
{ $values { "class" class } { "generic" generic } { "method" method-body } }
|
||||
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
|
||||
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
|
||||
|
||||
HELP: implementors
|
||||
{ $values { "class" class } { "seq" "a sequence of generic words" } }
|
||||
|
|
|
|||
|
|
@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
|
|||
\ = usage [ word? ] subset
|
||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
||||
] unit-test
|
||||
|
||||
GENERIC: generic-forget-test-3
|
||||
|
||||
M: f generic-forget-test-3 ;
|
||||
|
||||
[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
|
||||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
|
||||
|
||||
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ f ] [ f generic-forget-test-3 ] unit-test
|
||||
|
||||
: a-word ;
|
||||
|
||||
GENERIC: a-generic
|
||||
|
||||
M: integer a-generic a-word ;
|
||||
|
||||
[ ] [ \ integer \ a-generic method "m" set ] unit-test
|
||||
|
||||
[ t ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
|
||||
|
||||
[ f ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
|
|
|||
|
|
@ -17,10 +17,6 @@ M: object perform-combination
|
|||
#! the method will throw an error. We don't want that.
|
||||
nip [ "Invalid method combination" throw ] curry [ ] like ;
|
||||
|
||||
GENERIC: method-prologue ( class combination -- quot )
|
||||
|
||||
M: object method-prologue 2drop [ ] ;
|
||||
|
||||
GENERIC: make-default-method ( generic combination -- method )
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
|
@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
|
|||
: check-method ( class generic -- class generic )
|
||||
over class? over generic? and [
|
||||
\ check-method construct-boa throw
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
: with-methods ( word quot -- )
|
||||
: with-methods ( generic quot -- )
|
||||
swap [ "methods" word-prop swap call ] keep make-generic ;
|
||||
inline
|
||||
|
||||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot class generic -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method-def" word-prop >boolean ;
|
||||
PREDICATE: word method-body
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
: method-word-props ( quot class generic -- assoc )
|
||||
: method-word-props ( class generic -- assoc )
|
||||
[
|
||||
"method-generic" set
|
||||
"method-class" set
|
||||
"method-def" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
: <method> ( class generic -- method )
|
||||
check-method
|
||||
[ make-method-def ] 3keep
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
tuck set-word-props
|
||||
dup rot define ;
|
||||
[ set-word-props ] keep ;
|
||||
|
||||
: redefine-method ( quot class generic -- )
|
||||
[ method swap "method-def" set-word-prop ] 3keep
|
||||
[ make-method-def ] 2keep
|
||||
method swap define ;
|
||||
: reveal-method ( method class generic -- )
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
2dup method [
|
||||
redefine-method
|
||||
: create-method ( class generic -- method )
|
||||
2dup method dup [
|
||||
2nip
|
||||
] [
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods
|
||||
drop [ <method> dup ] 2keep reveal-method
|
||||
] if ;
|
||||
|
||||
: <default-method> ( generic combination -- method )
|
||||
object bootstrap-word pick <method>
|
||||
[ -rot make-default-method define ] keep ;
|
||||
|
||||
: define-default-method ( generic combination -- )
|
||||
dupd make-default-method object bootstrap-word pick <method>
|
||||
"default-method" set-word-prop ;
|
||||
dupd <default-method> "default-method" set-word-prop ;
|
||||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
|
|
@ -108,30 +98,31 @@ M: method-spec set-where
|
|||
first2 method set-where ;
|
||||
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
first2 method definer ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup
|
||||
[ "method-def" word-prop ] when ;
|
||||
first2 method definition ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ forget-word ] [ drop ] if ;
|
||||
dup generic? [
|
||||
[ delete-at* ] with-methods
|
||||
[ forget-word ] [ drop ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
first2 method forget* ;
|
||||
|
||||
M: method-body definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method-def" word-prop ;
|
||||
|
||||
M: method-body forget*
|
||||
dup "method-class" word-prop
|
||||
swap "method-generic" word-prop
|
||||
forget-method ;
|
||||
dup "forgotten" word-prop [ drop ] [
|
||||
dup "method-class" word-prop
|
||||
over "method-generic" word-prop forget-method
|
||||
t "forgotten" set-word-prop
|
||||
] if ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
all-words [
|
||||
|
|
@ -163,16 +154,12 @@ M: assoc update-methods ( assoc -- )
|
|||
make-generic
|
||||
] if ;
|
||||
|
||||
GENERIC: subwords ( word -- seq )
|
||||
|
||||
M: word subwords drop f ;
|
||||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
dup subwords [ forget ] each (forget-word) ;
|
||||
|
||||
: xref-generics ( -- )
|
||||
all-words [ subwords [ xref ] each ] each ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
|
|||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ word-def ]
|
||||
[ 1quotation ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
|
|
@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ;
|
|||
2dup and [
|
||||
2dup math-upgrade >r
|
||||
math-class-max over order min-class applicable-method
|
||||
r> swap append
|
||||
r> prepend
|
||||
] [
|
||||
2drop object-method
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -8,10 +8,6 @@ IN: generic.standard
|
|||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
M: standard-combination method-prologue
|
||||
standard-combination-# object
|
||||
<array> swap add* [ declare ] curry ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
|
@ -165,7 +161,7 @@ C: <hook-combination> hook-combination
|
|||
0 (dispatch#) [
|
||||
swap slip
|
||||
hook-combination-var [ get ] curry
|
||||
swap append
|
||||
prepend
|
||||
] with-variable ; inline
|
||||
|
||||
M: hook-combination make-default-method
|
||||
|
|
@ -174,7 +170,7 @@ M: hook-combination make-default-method
|
|||
M: hook-combination perform-combination
|
||||
[
|
||||
standard-methods
|
||||
[ [ drop ] swap append ] assoc-map
|
||||
[ [ drop ] prepend ] assoc-map
|
||||
single-combination
|
||||
] with-hook ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
|
|||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts ;
|
||||
system layouts vectors ;
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
|
|
@ -294,4 +294,6 @@ cell-bits 32 = [
|
|||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.encodings.binary SYMBOL: binary
|
||||
USING: io.encodings kernel ;
|
||||
IN: io.encodings.binary
|
||||
|
||||
TUPLE: binary ;
|
||||
M: binary <encoder> drop ;
|
||||
M: binary <decoder> drop ;
|
||||
|
|
|
|||
|
|
@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ;
|
|||
|
||||
ARTICLE: "encodings-protocol" "Encoding protocol"
|
||||
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
|
||||
{ $subsection decode-step }
|
||||
{ $subsection init-decoder }
|
||||
{ $subsection stream-write-encoded } ;
|
||||
{ $subsection decode-char }
|
||||
{ $subsection encode-char }
|
||||
"The following methods are optional:"
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> } ;
|
||||
|
||||
HELP: decode-step ( buf char encoding -- )
|
||||
{ $values { "buf" "A string buffer which characters can be pushed to" }
|
||||
{ "char" "An octet which is read from a stream" }
|
||||
HELP: decode-char ( stream encoding -- char/f )
|
||||
{ $values { "stream" "an underlying input stream" }
|
||||
{ "encoding" "An encoding descriptor tuple" } }
|
||||
{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
|
||||
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
|
||||
|
||||
HELP: stream-write-encoded ( string stream encoding -- )
|
||||
{ $values { "string" "a string" }
|
||||
{ "stream" "an output stream" }
|
||||
HELP: encode-char ( char stream encoding -- )
|
||||
{ $values { "char" "a character" }
|
||||
{ "stream" "an underlying output stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
|
||||
{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
|
||||
|
||||
HELP: init-decoder ( stream encoding -- encoding )
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
|
||||
|
||||
{ init-decoder decode-step stream-write-encoded } related-words
|
||||
{ encode-char decode-char } related-words
|
||||
|
|
|
|||
|
|
@ -2,62 +2,43 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces
|
||||
growable strings io classes continuations combinators
|
||||
io.styles io.streams.plain io.encodings.binary splitting
|
||||
io.streams.duplex byte-arrays ;
|
||||
io.styles io.streams.plain splitting
|
||||
io.streams.duplex byte-arrays sequences.private ;
|
||||
IN: io.encodings
|
||||
|
||||
! The encoding descriptor protocol
|
||||
|
||||
GENERIC: decode-step ( buf char encoding -- )
|
||||
M: object decode-step drop swap push ;
|
||||
GENERIC: decode-char ( stream encoding -- char/f )
|
||||
|
||||
GENERIC: init-decoder ( stream encoding -- encoding )
|
||||
M: tuple-class init-decoder construct-empty init-decoder ;
|
||||
M: object init-decoder nip ;
|
||||
GENERIC: encode-char ( char stream encoding -- )
|
||||
|
||||
GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
|
||||
M: object stream-write-encoded drop stream-write ;
|
||||
GENERIC: <decoder> ( stream decoding -- newstream )
|
||||
|
||||
! Decoding
|
||||
: replacement-char HEX: fffd ;
|
||||
|
||||
TUPLE: decoder stream code cr ;
|
||||
|
||||
TUPLE: decode-error ;
|
||||
|
||||
: decode-error ( -- * ) \ decode-error construct-empty throw ;
|
||||
|
||||
SYMBOL: begin
|
||||
GENERIC: <encoder> ( stream encoding -- newstream )
|
||||
|
||||
: push-decoded ( buf ch -- buf ch state )
|
||||
over push 0 begin ;
|
||||
TUPLE: encoder stream code ;
|
||||
|
||||
: push-replacement ( buf -- buf ch state )
|
||||
! This is the replacement character
|
||||
HEX: fffd push-decoded ;
|
||||
TUPLE: encode-error ;
|
||||
|
||||
: space ( resizable -- room-left )
|
||||
dup underlying swap [ length ] 2apply - ;
|
||||
: encode-error ( -- * ) \ encode-error construct-empty throw ;
|
||||
|
||||
: full? ( resizable -- ? ) space zero? ;
|
||||
! Decoding
|
||||
|
||||
: end-read-loop ( buf ch state stream quot -- string/f )
|
||||
2drop 2drop >string f like ;
|
||||
<PRIVATE
|
||||
|
||||
: decode-read-loop ( buf stream encoding -- string/f )
|
||||
pick full? [ 2drop >string ] [
|
||||
over stream-read1 [
|
||||
-rot tuck >r >r >r dupd r> decode-step r> r>
|
||||
decode-read-loop
|
||||
] [ 2drop >string f like ] if*
|
||||
] if ;
|
||||
M: tuple-class <decoder> construct-empty <decoder> ;
|
||||
M: tuple <decoder> f decoder construct-boa ;
|
||||
|
||||
: decode-read ( length stream encoding -- string )
|
||||
rot <sbuf> -rot decode-read-loop ;
|
||||
|
||||
TUPLE: decoder code cr ;
|
||||
: <decoder> ( stream encoding -- newstream )
|
||||
dup binary eq? [ drop ] [
|
||||
dupd init-decoder { set-delegate set-decoder-code }
|
||||
decoder construct
|
||||
] if ;
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
{ decoder-stream decoder-code } get-slots ;
|
||||
|
||||
: cr+ t swap set-decoder-cr ; inline
|
||||
|
||||
|
|
@ -82,72 +63,78 @@ TUPLE: decoder code cr ;
|
|||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
swap stream-read1 [ add ] when*
|
||||
] [ nip ] if
|
||||
] [ nip ] if ;
|
||||
over stream-read1 [ add ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
: read-loop ( n stream -- string )
|
||||
SBUF" " clone [
|
||||
[
|
||||
>r nip stream-read1 dup
|
||||
[ r> push f ] [ r> 2drop t ] if
|
||||
] 2curry find-integer drop
|
||||
] keep "" like f like ;
|
||||
|
||||
M: decoder stream-read
|
||||
tuck { delegate decoder-code } get-slots decode-read fix-read ;
|
||||
tuck read-loop fix-read ;
|
||||
|
||||
M: decoder stream-read-partial stream-read ;
|
||||
|
||||
: decoder-read-until ( stream delim -- ch )
|
||||
! Copied from { c-reader stream-read-until }!!!
|
||||
over stream-read1 dup [
|
||||
dup pick memq? [ 2nip ] [ , decoder-read-until ] if
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
: (read-until) ( buf quot -- string/f sep/f )
|
||||
! quot: -- char stop?
|
||||
dup call
|
||||
[ >r drop "" like r> ]
|
||||
[ pick push (read-until) ] if ; inline
|
||||
|
||||
M: decoder stream-read-until
|
||||
! Copied from { c-reader stream-read-until }!!!
|
||||
[ swap decoder-read-until ] "" make
|
||||
swap over empty? over not and [ 2drop f f ] when ;
|
||||
SBUF" " clone -rot >decoder<
|
||||
[ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
|
||||
(read-until) ;
|
||||
|
||||
: fix-read1 ( stream char -- char )
|
||||
over decoder-cr [
|
||||
over cr-
|
||||
dup CHAR: \n = [
|
||||
drop stream-read1
|
||||
] [ nip ] if
|
||||
] [ nip ] if ;
|
||||
drop dup stream-read1
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
M: decoder stream-read1
|
||||
1 swap stream-read f like [ first ] [ f ] if* ;
|
||||
dup >decoder< decode-char fix-read1 ;
|
||||
|
||||
M: decoder stream-readln ( stream -- str )
|
||||
"\r\n" over stream-read-until handle-readln ;
|
||||
|
||||
M: decoder dispose decoder-stream dispose ;
|
||||
|
||||
! Encoding
|
||||
M: tuple-class <encoder> construct-empty <encoder> ;
|
||||
M: tuple <encoder> encoder construct-boa ;
|
||||
|
||||
TUPLE: encode-error ;
|
||||
|
||||
: encode-error ( -- * ) \ encode-error construct-empty throw ;
|
||||
|
||||
TUPLE: encoder code ;
|
||||
: <encoder> ( stream encoding -- newstream )
|
||||
dup binary eq? [ drop ] [
|
||||
construct-empty { set-delegate set-encoder-code }
|
||||
encoder construct
|
||||
] if ;
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
{ encoder-stream encoder-code } get-slots ;
|
||||
|
||||
M: encoder stream-write1
|
||||
>r 1string r> stream-write ;
|
||||
>encoder< encode-char ;
|
||||
|
||||
M: encoder stream-write
|
||||
{ delegate encoder-code } get-slots stream-write-encoded ;
|
||||
>encoder< [ encode-char ] 2curry each ;
|
||||
|
||||
M: encoder dispose delegate dispose ;
|
||||
M: encoder dispose encoder-stream dispose ;
|
||||
|
||||
M: encoder stream-flush encoder-stream stream-flush ;
|
||||
|
||||
INSTANCE: encoder plain-writer
|
||||
|
||||
! Rebinding duplex streams which have not read anything yet
|
||||
|
||||
: reencode ( stream encoding -- newstream )
|
||||
over encoder? [ >r delegate r> ] when <encoder> ;
|
||||
over encoder? [ >r encoder-stream r> ] when <encoder> ;
|
||||
|
||||
: redecode ( stream encoding -- newstream )
|
||||
over decoder? [ >r delegate r> ] when <decoder> ;
|
||||
over decoder? [ >r decoder-stream r> ] when <decoder> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
|
||||
tuck reencode >r redecode r> <duplex-stream> ;
|
||||
|
|
|
|||
|
|
@ -6,82 +6,68 @@ IN: io.encodings.utf8
|
|||
|
||||
! Decoding UTF-8
|
||||
|
||||
TUPLE: utf8 ch state ;
|
||||
TUPLE: utf8 ;
|
||||
|
||||
SYMBOL: double
|
||||
SYMBOL: triple
|
||||
SYMBOL: triple2
|
||||
SYMBOL: quad
|
||||
SYMBOL: quad2
|
||||
SYMBOL: quad3
|
||||
<PRIVATE
|
||||
|
||||
: starts-2? ( char -- ? )
|
||||
-6 shift BIN: 10 number= ;
|
||||
dup [ -6 shift BIN: 10 number= ] when ;
|
||||
|
||||
: append-nums ( buf bottom top state-out -- buf num state )
|
||||
>r over starts-2?
|
||||
[ 6 shift swap BIN: 111111 bitand bitor r> ]
|
||||
[ r> 3drop push-replacement ] if ;
|
||||
: append-nums ( stream byte -- stream char )
|
||||
over stream-read1 dup starts-2?
|
||||
[ swap 6 shift swap BIN: 111111 bitand bitor ]
|
||||
[ 2drop replacement-char ] if ;
|
||||
|
||||
: begin-utf8 ( buf byte -- buf ch state )
|
||||
: double ( stream byte -- stream char )
|
||||
BIN: 11111 bitand append-nums ;
|
||||
|
||||
: triple ( stream byte -- stream char )
|
||||
BIN: 1111 bitand append-nums append-nums ;
|
||||
|
||||
: quad ( stream byte -- stream char )
|
||||
BIN: 111 bitand append-nums append-nums append-nums ;
|
||||
|
||||
: begin-utf8 ( stream byte -- stream char )
|
||||
{
|
||||
{ [ dup -7 shift zero? ] [ push-decoded ] }
|
||||
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
|
||||
{ [ t ] [ drop push-replacement ] }
|
||||
{ [ dup -7 shift zero? ] [ ] }
|
||||
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
|
||||
{ [ t ] [ drop replacement-char ] }
|
||||
} cond ;
|
||||
|
||||
: end-multibyte ( buf byte ch -- buf ch state )
|
||||
f append-nums [ push-decoded ] unless* ;
|
||||
: decode-utf8 ( stream -- char/f )
|
||||
dup stream-read1 dup [ begin-utf8 ] when nip ;
|
||||
|
||||
: decode-utf8-step ( buf byte ch state -- buf ch state )
|
||||
{
|
||||
{ begin [ drop begin-utf8 ] }
|
||||
{ double [ end-multibyte ] }
|
||||
{ triple [ triple2 append-nums ] }
|
||||
{ triple2 [ end-multibyte ] }
|
||||
{ quad [ quad2 append-nums ] }
|
||||
{ quad2 [ quad3 append-nums ] }
|
||||
{ quad3 [ end-multibyte ] }
|
||||
} case ;
|
||||
|
||||
: unpack-state ( encoding -- ch state )
|
||||
{ utf8-ch utf8-state } get-slots ;
|
||||
|
||||
: pack-state ( ch state encoding -- )
|
||||
{ set-utf8-ch set-utf8-state } set-slots ;
|
||||
|
||||
M: utf8 decode-step ( buf char encoding -- )
|
||||
[ unpack-state decode-utf8-step ] keep pack-state drop ;
|
||||
|
||||
M: utf8 init-decoder nip begin over set-utf8-state ;
|
||||
M: utf8 decode-char
|
||||
drop decode-utf8 ;
|
||||
|
||||
! Encoding UTF-8
|
||||
|
||||
: encoded ( char -- )
|
||||
BIN: 111111 bitand BIN: 10000000 bitor write1 ;
|
||||
: encoded ( stream char -- )
|
||||
BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
|
||||
|
||||
: char>utf8 ( char -- )
|
||||
: char>utf8 ( stream char -- )
|
||||
{
|
||||
{ [ dup -7 shift zero? ] [ write1 ] }
|
||||
{ [ dup -7 shift zero? ] [ swap stream-write1 ] }
|
||||
{ [ dup -11 shift zero? ] [
|
||||
dup -6 shift BIN: 11000000 bitor write1
|
||||
2dup -6 shift BIN: 11000000 bitor swap stream-write1
|
||||
encoded
|
||||
] }
|
||||
{ [ dup -16 shift zero? ] [
|
||||
dup -12 shift BIN: 11100000 bitor write1
|
||||
dup -6 shift encoded
|
||||
2dup -12 shift BIN: 11100000 bitor swap stream-write1
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
{ [ t ] [
|
||||
dup -18 shift BIN: 11110000 bitor write1
|
||||
dup -12 shift encoded
|
||||
dup -6 shift encoded
|
||||
2dup -18 shift BIN: 11110000 bitor swap stream-write1
|
||||
2dup -12 shift encoded
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
M: utf8 stream-write-encoded
|
||||
! For efficiency, this should be modified to avoid variable reads
|
||||
drop [ [ char>utf8 ] each ] with-stream* ;
|
||||
M: utf8 encode-char
|
||||
drop swap char>utf8 ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation"
|
|||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path+ }
|
||||
{ $subsection append-path }
|
||||
"Pathnames relative to Factor's install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
|
|
@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified )
|
|||
|
||||
{ stat exists? directory? } related-words
|
||||
|
||||
HELP: path+
|
||||
HELP: append-path
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
{ $description "Concatenates two pathnames." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- )
|
|||
: left-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] left-trim ;
|
||||
|
||||
: path+ ( str1 str2 -- str )
|
||||
: append-path ( str1 str2 -- str )
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
swap append-path ; inline
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
|
|
@ -86,16 +89,10 @@ SYMBOL: +unknown+
|
|||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
! : file-length ( path -- n ) stat drop 2nip ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
! : file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
! : directory? ( path -- ? ) stat 3drop ;
|
||||
|
||||
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
|
||||
|
||||
! Current working directory
|
||||
|
|
@ -125,7 +122,7 @@ HOOK: make-directory io-backend ( path -- )
|
|||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
[ tuck append-path directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
|
|
@ -133,7 +130,7 @@ HOOK: make-directory io-backend ( path -- )
|
|||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: directory* ( path -- seq )
|
||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
||||
dup directory [ first2 >r append-path r> 2array ] with map ;
|
||||
|
||||
! Touching files
|
||||
HOOK: touch-file io-backend ( path -- )
|
||||
|
|
@ -152,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- )
|
|||
: delete-tree ( path -- )
|
||||
dup directory? (delete-tree) ;
|
||||
|
||||
: to-directory over file-name path+ ;
|
||||
: to-directory over file-name append-path ;
|
||||
|
||||
! Moving and renaming files
|
||||
HOOK: move-file io-backend ( from to -- )
|
||||
|
|
@ -185,7 +182,7 @@ DEFER: copy-tree-into
|
|||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
>r dup directory swap r> [
|
||||
>r swap first path+ r> copy-tree-into
|
||||
>r swap first append-path r> copy-tree-into
|
||||
] 2curry each
|
||||
] [
|
||||
copy-file
|
||||
|
|
@ -200,7 +197,7 @@ DEFER: copy-tree-into
|
|||
! Special paths
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
prepend-path ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
|
|
@ -222,10 +219,7 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
dupd [ file-info file-info-size read ] with-file-reader ;
|
||||
|
||||
! : file-contents ( path encoding -- str )
|
||||
! dupd [ file-length read ] with-file-reader ;
|
||||
<file-reader> contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
|
@ -245,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
||||
: temp-file ( name -- path ) temp-directory prepend-path ;
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables generic kernel math namespaces sequences strings
|
||||
continuations assocs io.styles sbufs ;
|
||||
USING: hashtables generic kernel math namespaces sequences
|
||||
continuations assocs io.styles ;
|
||||
IN: io
|
||||
|
||||
GENERIC: stream-readln ( stream -- str )
|
||||
|
|
@ -88,4 +88,6 @@ SYMBOL: stderr
|
|||
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
|
||||
|
||||
: contents ( stream -- str )
|
||||
2048 <sbuf> [ stream-copy ] keep >string ;
|
||||
[
|
||||
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
|
||||
] with-stream ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
|
||||
sequences io namespaces ;
|
||||
sequences io namespaces io.encodings.private ;
|
||||
IN: io.streams.byte-array
|
||||
|
||||
: <byte-writer> ( encoding -- stream )
|
||||
|
|
@ -7,7 +7,7 @@ IN: io.streams.byte-array
|
|||
|
||||
: with-byte-writer ( encoding quot -- byte-array )
|
||||
>r <byte-writer> r> [ stdio get ] compose with-stream*
|
||||
>byte-array ; inline
|
||||
dup encoder? [ encoder-stream ] when >byte-array ; inline
|
||||
|
||||
: <byte-reader> ( byte-array encoding -- stream )
|
||||
>r >byte-vector dup reverse-here r> <decoder> ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io io.files threads
|
||||
strings byte-arrays io.streams.lines io.streams.plain ;
|
||||
strings byte-arrays io.streams.plain ;
|
||||
IN: io.streams.c
|
||||
|
||||
ARTICLE: "io.streams.c" "ANSI C streams"
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.string
|
||||
USING: io kernel math namespaces sequences sbufs strings
|
||||
generic splitting growable continuations io.streams.plain
|
||||
io.encodings ;
|
||||
io.encodings io.encodings.private ;
|
||||
IN: io.streams.string
|
||||
|
||||
M: growable dispose drop ;
|
||||
|
||||
|
|
@ -49,8 +49,11 @@ M: growable stream-read
|
|||
M: growable stream-read-partial
|
||||
stream-read ;
|
||||
|
||||
TUPLE: null ;
|
||||
M: null decode-char drop stream-read1 ;
|
||||
|
||||
: <string-reader> ( str -- stream )
|
||||
>sbuf dup reverse-here f <decoder> ;
|
||||
>sbuf dup reverse-here null <decoder> ;
|
||||
|
||||
: with-string-reader ( str quot -- )
|
||||
>r <string-reader> r> with-stream ; inline
|
||||
|
|
|
|||
|
|
@ -24,20 +24,40 @@ IN: optimizer.specializers
|
|||
\ dispatch ,
|
||||
] [ ] make ;
|
||||
|
||||
: specializer-methods ( quot word -- default alist )
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
[ declare ] curry pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop add* ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration [ declare ] curry prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
dup { number } = [
|
||||
drop tag-specializer
|
||||
] [
|
||||
specializer-cases alist>quot
|
||||
] if ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
"method-generic" word-prop standard-generic?
|
||||
] [ drop f ] if ;
|
||||
|
||||
: specialized-def ( word -- quot )
|
||||
dup word-def swap "specializer" word-prop [
|
||||
dup { number } = [
|
||||
drop tag-specializer
|
||||
] [
|
||||
specializer-methods alist>quot
|
||||
] if
|
||||
] when* ;
|
||||
dup word-def swap {
|
||||
{ [ dup standard-method? ] [ specialize-method ] }
|
||||
{
|
||||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays math parser tools.test kernel generic words
|
||||
io.streams.string namespaces classes effects source-files
|
||||
assocs sequences strings io.files definitions continuations
|
||||
sorting tuples compiler.units debugger ;
|
||||
sorting tuples compiler.units debugger vocabs.loader ;
|
||||
IN: parser.tests
|
||||
|
||||
[
|
||||
|
|
@ -397,35 +397,47 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
[
|
||||
"redefining-a-class-5" forget-source
|
||||
"redefining-a-class-6" forget-source
|
||||
"redefining-a-class-7" forget-source
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests M: f foo ;"
|
||||
<string-reader> "redefining-a-class-6" parse-stream drop
|
||||
] unit-test
|
||||
2 [
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests M: f foo ;"
|
||||
<string-reader> "redefining-a-class-6" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
|
||||
] times
|
||||
|
||||
[ "resource:core/parser/test/assert-depth.factor" run-file ]
|
||||
[ relative-overflow-stack { 1 2 3 } sequence= ]
|
||||
|
|
@ -447,3 +459,5 @@ must-fail-with
|
|||
<string-reader> "d-f-s-test" parse-stream drop
|
||||
] unit-test
|
||||
] times
|
||||
|
||||
[ ] [ "parser" reload ] unit-test
|
||||
|
|
|
|||
|
|
@ -215,9 +215,6 @@ SYMBOL: in
|
|||
: set-in ( name -- )
|
||||
check-vocab-string dup in set create-vocab (use+) ;
|
||||
|
||||
: create-in ( string -- word )
|
||||
in get create dup set-word dup save-location ;
|
||||
|
||||
TUPLE: unexpected want got ;
|
||||
|
||||
: unexpected ( want got -- * )
|
||||
|
|
@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
|
|||
: parse-tokens ( end -- seq )
|
||||
100 <vector> swap (parse-tokens) >array ;
|
||||
|
||||
: create-in ( string -- word )
|
||||
in get create dup set-word dup save-location ;
|
||||
|
||||
: CREATE ( -- word ) scan create-in ;
|
||||
|
||||
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
||||
|
||||
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
|
||||
|
||||
: create-class-in ( word -- word )
|
||||
in get create
|
||||
dup save-class-location
|
||||
|
|
@ -284,6 +288,12 @@ M: no-word summary
|
|||
] ?if
|
||||
] when ;
|
||||
|
||||
: create-method-in ( class generic -- method )
|
||||
create-method f set-word dup save-location ;
|
||||
|
||||
: CREATE-METHOD ( -- method )
|
||||
scan-word bootstrap-word scan-word create-method-in ;
|
||||
|
||||
TUPLE: staging-violation word ;
|
||||
|
||||
: staging-violation ( word -- * )
|
||||
|
|
@ -355,7 +365,9 @@ TUPLE: bad-number ;
|
|||
: parse-definition ( -- quot )
|
||||
\ ; parse-until >quotation ;
|
||||
|
||||
: (:) CREATE dup reset-generic parse-definition ;
|
||||
: (:) CREATE-WORD parse-definition ;
|
||||
|
||||
: (M:) CREATE-METHOD parse-definition ;
|
||||
|
||||
GENERIC: expected>string ( obj -- str )
|
||||
|
||||
|
|
@ -466,7 +478,15 @@ SYMBOL: interactive-vocabs
|
|||
: smudged-usage ( -- usages referenced removed )
|
||||
removed-definitions filter-moved keys [
|
||||
outside-usages
|
||||
[ empty? swap pathname? or not ] assoc-subset
|
||||
[
|
||||
empty? [ drop f ] [
|
||||
{
|
||||
{ [ dup pathname? ] [ f ] }
|
||||
{ [ dup method-body? ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
} cond nip
|
||||
] if
|
||||
] assoc-subset
|
||||
dup values concat prune swap keys
|
||||
] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -317,3 +317,15 @@ unit-test
|
|||
[ ] [ 1 \ + curry unparse drop ] unit-test
|
||||
|
||||
[ ] [ 1 \ + compose unparse drop ] unit-test
|
||||
|
||||
GENERIC: generic-see-test-with-f ( obj -- obj )
|
||||
|
||||
M: f generic-see-test-with-f ;
|
||||
|
||||
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
|
||||
[ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
|
||||
[ \ f \ generic-see-test-with-f method see ] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -172,13 +172,13 @@ M: hook-generic synopsis*
|
|||
stack-effect. ;
|
||||
|
||||
M: method-spec synopsis*
|
||||
dup definer. [ pprint-word ] each ;
|
||||
first2 method synopsis* ;
|
||||
|
||||
M: method-body synopsis*
|
||||
dup dup
|
||||
definer.
|
||||
"method-class" word-prop pprint*
|
||||
"method-generic" word-prop pprint* ;
|
||||
"method-class" word-prop pprint-word
|
||||
"method-generic" word-prop pprint-word ;
|
||||
|
||||
M: mixin-instance synopsis*
|
||||
dup definer.
|
||||
|
|
|
|||
|
|
@ -299,6 +299,8 @@ M: immutable-sequence clone-like like ;
|
|||
|
||||
: append ( seq1 seq2 -- newseq ) over (append) ;
|
||||
|
||||
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
|
||||
|
||||
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
|
||||
|
||||
: change-nth ( i seq quot -- )
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
|
|||
C: <slot-spec> slot-spec
|
||||
|
||||
: define-typecheck ( class generic quot -- )
|
||||
over define-simple-generic -rot define-method ;
|
||||
over define-simple-generic
|
||||
>r create-method r> define ;
|
||||
|
||||
: define-slot-word ( class slot word quot -- )
|
||||
rot >fixnum add* define-typecheck ;
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ IN: bootstrap.syntax
|
|||
"parsing" [ word t "parsing" set-word-prop ] define-syntax
|
||||
|
||||
"SYMBOL:" [
|
||||
CREATE dup reset-generic define-symbol
|
||||
CREATE-WORD define-symbol
|
||||
] define-syntax
|
||||
|
||||
"DEFER:" [
|
||||
|
|
@ -111,31 +111,26 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
"GENERIC:" [
|
||||
CREATE dup reset-word
|
||||
define-simple-generic
|
||||
CREATE-GENERIC define-simple-generic
|
||||
] define-syntax
|
||||
|
||||
"GENERIC#" [
|
||||
CREATE dup reset-word
|
||||
CREATE-GENERIC
|
||||
scan-word <standard-combination> define-generic
|
||||
] define-syntax
|
||||
|
||||
"MATH:" [
|
||||
CREATE dup reset-word
|
||||
CREATE-GENERIC
|
||||
T{ math-combination } define-generic
|
||||
] define-syntax
|
||||
|
||||
"HOOK:" [
|
||||
CREATE dup reset-word scan-word
|
||||
CREATE-GENERIC scan-word
|
||||
<hook-combination> define-generic
|
||||
] define-syntax
|
||||
|
||||
"M:" [
|
||||
f set-word
|
||||
location >r
|
||||
scan-word bootstrap-word scan-word
|
||||
[ parse-definition -rot define-method ] 2keep
|
||||
2array r> remember-definition
|
||||
(M:) define
|
||||
] define-syntax
|
||||
|
||||
"UNION:" [
|
||||
|
|
@ -163,11 +158,16 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
"C:" [
|
||||
CREATE dup reset-generic
|
||||
CREATE-WORD
|
||||
scan-word dup check-tuple
|
||||
[ construct-boa ] curry define-inline
|
||||
] define-syntax
|
||||
|
||||
"ERROR:" [
|
||||
CREATE-CLASS dup ";" parse-tokens define-tuple-class
|
||||
dup [ construct-boa throw ] curry define
|
||||
] define-syntax
|
||||
|
||||
"FORGET:" [
|
||||
scan-word
|
||||
dup parsing? [ V{ } clone swap execute first ] when
|
||||
|
|
|
|||
|
|
@ -14,3 +14,5 @@ yield
|
|||
[ 3 ] [
|
||||
[ 3 swap resume-with ] "Test suspend" suspend
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f get-global ] unit-test
|
||||
|
|
|
|||
|
|
@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
|
|||
|
||||
: threads 41 getenv ;
|
||||
|
||||
threads global [ H{ } assoc-like ] change-at
|
||||
|
||||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
: thread-registered? ( thread -- ? )
|
||||
|
|
|
|||
|
|
@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
|
|||
$nl
|
||||
"A shortcut for defining BOA constructors:"
|
||||
{ $subsection POSTPONE: C: }
|
||||
"Examples of constructors:"
|
||||
{ $code
|
||||
"TUPLE: color red green blue alpha ;"
|
||||
""
|
||||
"C: <rgba> rgba"
|
||||
": <rgba> color construct-boa ; ! identical to above"
|
||||
""
|
||||
": <rgb>"
|
||||
" { set-color-red set-color-green set-color-blue }"
|
||||
" color construct ;"
|
||||
": <rgb> f <rgba> ; ! identical to above"
|
||||
""
|
||||
": <color> construct-empty ;"
|
||||
": <color> { } color construct ; ! identical to above"
|
||||
": <color> f f f f <rgba> ; ! identical to above"
|
||||
}
|
||||
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
|
||||
|
||||
ARTICLE: "tuple-delegation" "Delegation"
|
||||
|
|
@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
|
|||
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
|
||||
{ $subsection POSTPONE: TUPLE: }
|
||||
"An example:"
|
||||
{ $code "TUPLE: person name address phone ;" }
|
||||
"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
|
||||
{ $code "TUPLE: person name address phone ;" "C: <person> person" }
|
||||
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
|
||||
{ $table
|
||||
{ "Reader" "Writer" }
|
||||
{ { $snippet "person-name" } { $snippet "set-person-name" } }
|
||||
|
|
|
|||
|
|
@ -43,8 +43,6 @@ HELP: find-vocab-root
|
|||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
||||
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
|
||||
|
||||
{ vocab-root find-vocab-root } related-words
|
||||
|
||||
HELP: no-vocab
|
||||
{ $values { "name" "a vocabulary name" } }
|
||||
{ $description "Throws a " { $link no-vocab } "." }
|
||||
|
|
|
|||
|
|
@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ;
|
|||
] unit-test
|
||||
|
||||
[ T{ vocab-link f "vocabs.loader.test" } ]
|
||||
[ "vocabs.loader.test" f >vocab-link ] unit-test
|
||||
[ "vocabs.loader.test" >vocab-link ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
|
||||
[ "kernel" >vocab-link "kernel" vocab = ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"kernel" vocab-files
|
||||
"kernel" vocab vocab-files
|
||||
"kernel" f <vocab-link> vocab-files
|
||||
"kernel" <vocab-link> vocab-files
|
||||
3array all-equal?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ IN: vocabs.loader.tests
|
|||
[ { 3 3 3 } ] [
|
||||
"vocabs.loader.test.2" run
|
||||
"vocabs.loader.test.2" vocab run
|
||||
"vocabs.loader.test.2" f <vocab-link> run
|
||||
"vocabs.loader.test.2" <vocab-link> run
|
||||
3array
|
||||
] unit-test
|
||||
|
||||
|
|
@ -78,6 +78,8 @@ IN: vocabs.loader.tests
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"vocabs.loader.test.b" vocab-files
|
||||
|
|
@ -113,11 +115,18 @@ IN: vocabs.loader.tests
|
|||
[ 3 ] [ "count-me" get-global ] unit-test
|
||||
|
||||
[ { "resource:core/kernel/kernel.factor" 1 } ]
|
||||
[ "kernel" f <vocab-link> where ] unit-test
|
||||
[ "kernel" <vocab-link> where ] unit-test
|
||||
|
||||
[ { "resource:core/kernel/kernel.factor" 1 } ]
|
||||
[ "kernel" vocab where ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"vocabs.loader.test.c" forget-vocab
|
||||
"vocabs.loader.test.d" forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "vocabs.loader.test.d" require ] [ :1 ] recover
|
||||
"vocabs.loader.test.d" vocab-source-loaded?
|
||||
|
|
@ -127,7 +136,7 @@ IN: vocabs.loader.tests
|
|||
[
|
||||
{ "2" "a" "b" "d" "e" "f" }
|
||||
[
|
||||
"vocabs.loader.test." swap append forget-vocab
|
||||
"vocabs.loader.test." prepend forget-vocab
|
||||
] each
|
||||
] with-compilation-unit ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,30 +23,30 @@ V{
|
|||
[ >r dup peek r> append add ] when*
|
||||
"/" join ;
|
||||
|
||||
: vocab-path+ ( vocab path -- newpath )
|
||||
swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
|
||||
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup ".factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup "-docs.factor" vocab-dir+ vocab-path+ ;
|
||||
|
||||
: vocab-dir? ( root name -- ? )
|
||||
over [
|
||||
".factor" vocab-dir+ path+ resource-exists?
|
||||
".factor" vocab-dir+ append-path resource-exists?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
SYMBOL: root-cache
|
||||
|
||||
H{ } clone root-cache set-global
|
||||
|
||||
: find-vocab-root ( vocab -- path/f )
|
||||
vocab-roots get swap [ vocab-dir? ] curry find nip ;
|
||||
vocab-name root-cache get [
|
||||
vocab-roots get swap [ vocab-dir? ] curry find nip
|
||||
] cache ;
|
||||
|
||||
M: string vocab-root
|
||||
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
|
||||
: vocab-append-path ( vocab path -- newpath )
|
||||
swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
|
||||
|
||||
M: vocab-link vocab-root
|
||||
vocab-link-root ;
|
||||
: vocab-source-path ( vocab -- path/f )
|
||||
dup ".factor" vocab-dir+ vocab-append-path ;
|
||||
|
||||
: vocab-docs-path ( vocab -- path/f )
|
||||
dup "-docs.factor" vocab-dir+ vocab-append-path ;
|
||||
|
||||
SYMBOL: load-help?
|
||||
|
||||
|
|
@ -56,7 +56,7 @@ SYMBOL: load-help?
|
|||
|
||||
: load-source ( vocab -- )
|
||||
[ source-wasn't-loaded ] keep
|
||||
[ vocab-source-path bootstrap-file ] keep
|
||||
[ vocab-source-path [ bootstrap-file ] when* ] keep
|
||||
source-was-loaded ;
|
||||
|
||||
: docs-were-loaded t swap set-vocab-docs-loaded? ;
|
||||
|
|
@ -66,24 +66,13 @@ SYMBOL: load-help?
|
|||
: load-docs ( vocab -- )
|
||||
load-help? get [
|
||||
[ docs-weren't-loaded ] keep
|
||||
[ vocab-docs-path ?run-file ] keep
|
||||
[ vocab-docs-path [ ?run-file ] when* ] keep
|
||||
docs-were-loaded
|
||||
] [ drop ] if ;
|
||||
|
||||
: create-vocab-with-root ( vocab-link -- vocab )
|
||||
dup vocab-name create-vocab
|
||||
swap vocab-root over set-vocab-root ;
|
||||
|
||||
: reload ( name -- )
|
||||
[
|
||||
f >vocab-link
|
||||
dup vocab-root [
|
||||
dup vocab-source-path resource-exists? [
|
||||
create-vocab-with-root
|
||||
dup load-source
|
||||
load-docs
|
||||
] [ no-vocab ] if
|
||||
] [ no-vocab ] if
|
||||
dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
|
||||
] with-compiler-errors ;
|
||||
|
||||
: require ( vocab -- )
|
||||
|
|
@ -100,33 +89,33 @@ SYMBOL: load-help?
|
|||
|
||||
SYMBOL: blacklist
|
||||
|
||||
GENERIC: (load-vocab) ( name -- vocab )
|
||||
|
||||
: add-to-blacklist ( error vocab -- )
|
||||
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
|
||||
|
||||
GENERIC: (load-vocab) ( name -- )
|
||||
|
||||
M: vocab (load-vocab)
|
||||
[
|
||||
dup vocab-root [
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
] when
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
drop
|
||||
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
|
||||
|
||||
M: string (load-vocab)
|
||||
[ ".private" ?tail drop reload ] keep vocab ;
|
||||
|
||||
M: vocab-link (load-vocab)
|
||||
vocab-name (load-vocab) ;
|
||||
vocab-name create-vocab (load-vocab) ;
|
||||
|
||||
M: string (load-vocab)
|
||||
create-vocab (load-vocab) ;
|
||||
|
||||
[
|
||||
dup vocab-name blacklist get at* [
|
||||
rethrow
|
||||
] [
|
||||
drop
|
||||
[ dup vocab swap or (load-vocab) ] with-compiler-errors
|
||||
] if
|
||||
|
||||
[
|
||||
dup vocab-name blacklist get at* [
|
||||
rethrow
|
||||
] [
|
||||
drop
|
||||
[ (load-vocab) ] with-compiler-errors
|
||||
] if
|
||||
] with-compiler-errors
|
||||
] load-vocab-hook set-global
|
||||
|
||||
: vocab-where ( vocab -- loc )
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ $nl
|
|||
{ $subsection vocab }
|
||||
"Accessors for various vocabulary attributes:"
|
||||
{ $subsection vocab-name }
|
||||
{ $subsection vocab-root }
|
||||
{ $subsection vocab-main }
|
||||
{ $subsection vocab-help }
|
||||
"Looking up existing vocabularies and creating new vocabularies:"
|
||||
|
|
@ -50,10 +49,6 @@ HELP: vocab-name
|
|||
{ $values { "vocab" "a vocabulary specifier" } { "name" string } }
|
||||
{ $description "Outputs the name of a vocabulary." } ;
|
||||
|
||||
HELP: vocab-root
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
|
||||
{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
|
||||
|
||||
HELP: vocab-words
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
|
||||
{ $description "Outputs the words defined in a vocabulary." } ;
|
||||
|
|
@ -101,11 +96,11 @@ HELP: child-vocabs
|
|||
} ;
|
||||
|
||||
HELP: vocab-link
|
||||
{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
|
||||
{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
|
||||
$nl
|
||||
"Vocabulary links are created by calling " { $link >vocab-link } "."
|
||||
} ;
|
||||
|
||||
HELP: >vocab-link
|
||||
{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
|
||||
{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
|
|||
M: vocab equal? 2drop f ;
|
||||
|
||||
: <vocab> ( name -- vocab )
|
||||
H{ } clone t
|
||||
{ set-vocab-name set-vocab-words set-vocab-source-loaded? }
|
||||
H{ } clone
|
||||
{ set-vocab-name set-vocab-words }
|
||||
\ vocab construct ;
|
||||
|
||||
GENERIC: vocab ( vocab-spec -- vocab )
|
||||
|
|
@ -60,9 +60,16 @@ M: f vocab-help ;
|
|||
: create-vocab ( name -- vocab )
|
||||
dictionary get [ <vocab> ] cache ;
|
||||
|
||||
SYMBOL: load-vocab-hook
|
||||
TUPLE: no-vocab name ;
|
||||
|
||||
: load-vocab ( name -- vocab ) load-vocab-hook get call ;
|
||||
: no-vocab ( name -- * )
|
||||
vocab-name \ no-vocab construct-boa throw ;
|
||||
|
||||
SYMBOL: load-vocab-hook ! ( name -- )
|
||||
|
||||
: load-vocab ( name -- vocab )
|
||||
dup load-vocab-hook get call
|
||||
dup vocab [ ] [ no-vocab ] ?if ;
|
||||
|
||||
: vocabs ( -- seq )
|
||||
dictionary get keys natural-sort ;
|
||||
|
|
@ -85,10 +92,10 @@ SYMBOL: load-vocab-hook
|
|||
: child-vocabs ( vocab -- seq )
|
||||
vocab-name vocabs [ child-vocab? ] with subset ;
|
||||
|
||||
TUPLE: vocab-link name root ;
|
||||
TUPLE: vocab-link name ;
|
||||
|
||||
: <vocab-link> ( name root -- vocab-link )
|
||||
[ dup vocab-root ] unless* vocab-link construct-boa ;
|
||||
: <vocab-link> ( name -- vocab-link )
|
||||
vocab-link construct-boa ;
|
||||
|
||||
M: vocab-link equal?
|
||||
over vocab-link?
|
||||
|
|
@ -99,24 +106,16 @@ M: vocab-link hashcode*
|
|||
|
||||
M: vocab-link vocab-name vocab-link-name ;
|
||||
|
||||
GENERIC# >vocab-link 1 ( name root -- vocab )
|
||||
|
||||
M: vocab >vocab-link drop ;
|
||||
|
||||
M: vocab-link >vocab-link drop ;
|
||||
|
||||
M: string >vocab-link
|
||||
over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
|
||||
|
||||
UNION: vocab-spec vocab vocab-link ;
|
||||
|
||||
GENERIC: >vocab-link ( name -- vocab )
|
||||
|
||||
M: vocab-spec >vocab-link ;
|
||||
|
||||
M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
|
||||
|
||||
: forget-vocab ( vocab -- )
|
||||
dup words forget-all
|
||||
vocab-name dictionary get delete-at ;
|
||||
|
||||
M: vocab-spec forget* forget-vocab ;
|
||||
|
||||
TUPLE: no-vocab name ;
|
||||
|
||||
: no-vocab ( name -- * )
|
||||
vocab-name \ no-vocab construct-boa throw ;
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
|
|||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method-def" word-prop ] [ t ] }
|
||||
{ [ dup "method-generic" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
@ -169,7 +169,12 @@ SYMBOL: changed-words
|
|||
"declared-effect" "constructor-quot" "delimiter"
|
||||
} reset-props ;
|
||||
|
||||
GENERIC: subwords ( word -- seq )
|
||||
|
||||
M: word subwords drop f ;
|
||||
|
||||
: reset-generic ( word -- )
|
||||
dup subwords [ forget ] each
|
||||
dup reset-word
|
||||
{ "methods" "combination" "default-method" } reset-props ;
|
||||
|
||||
|
|
|
|||
|
|
@ -135,18 +135,18 @@ SYMBOL: end
|
|||
GENERIC: >ber ( obj -- byte-array )
|
||||
M: fixnum >ber ( n -- byte-array )
|
||||
>128-ber dup length 2 swap 2array
|
||||
"cc" pack-native swap append ;
|
||||
"cc" pack-native prepend ;
|
||||
|
||||
: >ber-enumerated ( n -- byte-array )
|
||||
>128-ber >byte-array dup length 10 swap 2array
|
||||
"CC" pack-native swap append ;
|
||||
"CC" pack-native prepend ;
|
||||
|
||||
: >ber-length-encoding ( n -- byte-array )
|
||||
dup 127 <= [
|
||||
1array "C" pack-be
|
||||
] [
|
||||
1array "I" pack-be 0 swap remove dup length
|
||||
HEX: 80 + 1array "C" pack-be swap append
|
||||
HEX: 80 + 1array "C" pack-be prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array )
|
|||
dup 126 > [
|
||||
"range error in bignum" throw
|
||||
] [
|
||||
2 swap 2array "CC" pack-native swap append
|
||||
2 swap 2array "CC" pack-native prepend
|
||||
] if ;
|
||||
|
||||
! =========================================================
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ IN: assocs.lib
|
|||
>r 2array flip r> assoc-like ;
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
>r random-256 >hex r>
|
||||
>r 256 random-bits >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
||||
: set-at-unique ( value assoc -- key )
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
|||
|
||||
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
|
||||
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
||||
|
||||
: wrap-line ( a-line-z -- za-line-za )
|
||||
dup peek 1array swap dup first 1array append append ;
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
|||
>r keys r> define-slots ;
|
||||
|
||||
: define-setters ( classname slots -- )
|
||||
>r "with-" swap append r>
|
||||
>r "with-" prepend r>
|
||||
dup values [setters]
|
||||
>r keys r> define-slots ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,11 +9,10 @@ IN: bootstrap.help
|
|||
|
||||
t load-help? set-global
|
||||
|
||||
[ vocab ] load-vocab-hook [
|
||||
[ drop ] load-vocab-hook [
|
||||
vocabs
|
||||
[ vocab-root ] subset
|
||||
[ vocab-source-loaded? ] subset
|
||||
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
|
||||
[ vocab-docs-loaded? not ] subset
|
||||
[ load-docs ] each
|
||||
] with-variable ;
|
||||
|
||||
load-help
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ bootstrap.image sequences io ;
|
|||
: download-image ( arch -- )
|
||||
boot-image-name dup need-new-image? [
|
||||
"Downloading " write dup write "..." print
|
||||
url swap append download
|
||||
url prepend download
|
||||
] [
|
||||
"Boot image up to date" print
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
USING: vocabs.loader sequences system ;
|
||||
|
||||
"random.mersenne-twister" require
|
||||
|
||||
{
|
||||
{ [ windows? ] [ "random.windows" require ] }
|
||||
{ [ unix? ] [ "random.unix" require ] }
|
||||
} cond
|
||||
|
|
@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
|
|||
"tools.threads"
|
||||
"tools.vocabs"
|
||||
"tools.vocabs.browser"
|
||||
"tools.vocabs.monitor"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel vocabs vocabs.loader sequences system ;
|
||||
|
||||
{ "ui" "help" "tools" }
|
||||
[ "bootstrap." swap append vocab ] all? [
|
||||
[ "bootstrap." prepend vocab ] all? [
|
||||
"ui.tools" require
|
||||
|
||||
"ui.cocoa" vocab [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ vocabs vocabs.loader ;
|
|||
{ [ windows? ] [ "windows" ] }
|
||||
{ [ unix? ] [ "x11" ] }
|
||||
} cond
|
||||
] unless* "ui." swap append require
|
||||
] unless* "ui." prepend require
|
||||
|
||||
"ui.freetype" require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
|
|||
|
||||
IN: builder.benchmark
|
||||
|
||||
: passing-benchmarks ( table -- table )
|
||||
[ second first2 number? swap number? and ] subset ;
|
||||
! : passing-benchmarks ( table -- table )
|
||||
! [ second first2 number? swap number? and ] subset ;
|
||||
|
||||
: simplify-table ( table -- table ) [ first2 second 2array ] map ;
|
||||
: passing-benchmarks ( table -- table ) [ second number? ] subset ;
|
||||
|
||||
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
|
||||
|
||||
: benchmark-difference ( old-table benchmark-result -- result-diff )
|
||||
first2 >r
|
||||
|
|
@ -17,7 +19,7 @@ IN: builder.benchmark
|
|||
2array ;
|
||||
|
||||
: compare-tables ( old new -- table )
|
||||
[ passing-benchmarks simplify-table ] 2apply
|
||||
[ passing-benchmarks ] 2apply
|
||||
[ benchmark-difference ] with map ;
|
||||
|
||||
: benchmark-deltas ( -- table )
|
||||
|
|
|
|||
|
|
@ -58,8 +58,8 @@ IN: builder
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: copy-image ( -- )
|
||||
builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
|
||||
builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
|
||||
builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
|
||||
builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: builder.release
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: releases ( -- path )
|
||||
builds "releases" path+
|
||||
builds "releases" append-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded
|
||||
combinators.lib continuations kernel math multiline
|
||||
combinators.cleave continuations kernel math multiline
|
||||
opengl opengl.shaders opengl.framebuffers opengl.gl
|
||||
opengl.capabilities sequences ui.gadgets combinators.cleave ;
|
||||
IN: bunny.outlined
|
||||
|
|
|
|||
|
|
@ -22,11 +22,11 @@ IN: cairo-demo
|
|||
|
||||
TUPLE: cairo-gadget image-array cairo-t ;
|
||||
|
||||
! M: cairo-gadget draw-gadget* ( gadget -- )
|
||||
! 0 0 glRasterPos2i
|
||||
! 1.0 -1.0 glPixelZoom
|
||||
! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
|
||||
! cairo-gadget-image-array glDrawPixels ;
|
||||
M: cairo-gadget draw-gadget* ( gadget -- )
|
||||
0 0 glRasterPos2i
|
||||
1.0 -1.0 glPixelZoom
|
||||
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
|
||||
cairo-gadget-image-array glDrawPixels ;
|
||||
|
||||
: create-surface ( gadget -- cairo_surface_t )
|
||||
make-image-array
|
||||
|
|
@ -60,8 +60,8 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
|
|||
M: cairo-gadget graft* ( gadget -- )
|
||||
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
|
||||
|
||||
! M: cairo-gadget ungraft* ( gadget -- )
|
||||
! cairo-gadget-cairo-t cairo_destroy ;
|
||||
M: cairo-gadget ungraft* ( gadget -- )
|
||||
cairo-gadget-cairo-t cairo_destroy ;
|
||||
|
||||
: <cairo-gadget> ( -- gadget )
|
||||
cairo-gadget construct-gadget ;
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ USING: kernel ;
|
|||
IN: calendar.backend
|
||||
|
||||
SYMBOL: calendar-backend
|
||||
HOOK: gmt-offset calendar-backend
|
||||
HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test
|
|||
continuations system ;
|
||||
IN: calendar.tests
|
||||
|
||||
[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ t ] [ now valid-timestamp? ] unit-test
|
||||
|
||||
[ f ] [ 1900 leap-year? ] unit-test
|
||||
|
|
@ -18,126 +18,126 @@ IN: calendar.tests
|
|||
[ f ] [ 2001 leap-year? ] unit-test
|
||||
[ f ] [ 2006 leap-year? ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 instant <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
|
||||
[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
|
||||
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
|
||||
|
||||
[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 instant <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
|
||||
2004 1 1 11 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
|
||||
2004 1 1 16 0 0 instant <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
|
||||
2004 1 1 13 30 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
|
||||
[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,20 +3,23 @@
|
|||
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings tuples system vocabs.loader calendar.backend threads
|
||||
new-slots accessors combinators ;
|
||||
new-slots accessors combinators locals ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset <timestamp> ;
|
||||
|
||||
TUPLE: duration year month day hour minute second ;
|
||||
|
||||
C: <duration> duration
|
||||
|
||||
: gmt-offset-duration ( -- duration )
|
||||
0 0 0 gmt-offset <duration> ;
|
||||
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset-duration <timestamp> ;
|
||||
|
||||
: month-names
|
||||
{
|
||||
"Not a month" "January" "February" "March" "April" "May" "June"
|
||||
|
|
@ -226,16 +229,18 @@ M: duration <=> [ dt>years ] compare ;
|
|||
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
|
||||
: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
|
||||
|
||||
: convert-timezone ( timestamp n -- timestamp )
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
|
||||
: convert-timezone ( timestamp duration -- timestamp )
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
[ over gmt-offset>> - hours time+ ] keep >>gmt-offset
|
||||
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
|
||||
] if ;
|
||||
|
||||
: >local-time ( timestamp -- timestamp )
|
||||
gmt-offset convert-timezone ;
|
||||
gmt-offset-duration convert-timezone ;
|
||||
|
||||
: >gmt ( timestamp -- timestamp )
|
||||
0 convert-timezone ;
|
||||
instant convert-timezone ;
|
||||
|
||||
M: timestamp <=> ( ts1 ts2 -- n )
|
||||
[ >gmt tuple-slots ] compare ;
|
||||
|
|
@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
|
||||
M: timestamp time-
|
||||
#! Exact calendar-time difference
|
||||
(time-) seconds ;
|
||||
|
|
@ -263,14 +266,14 @@ M: timestamp time-
|
|||
M: duration time-
|
||||
before time+ ;
|
||||
|
||||
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
|
||||
: <zero> 0 0 0 0 0 0 instant <timestamp> ;
|
||||
|
||||
: valid-timestamp? ( timestamp -- ? )
|
||||
clone 0 >>gmt-offset
|
||||
clone instant >>gmt-offset
|
||||
dup <zero> time- <zero> time+ = ;
|
||||
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ; foldable
|
||||
1970 1 1 0 0 0 instant <timestamp> ; foldable
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: calendar.format calendar kernel tools.test
|
||||
io.streams.string ;
|
||||
IN: calendar.format.tests
|
||||
USING: calendar.format tools.test io.streams.string ;
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
|
|
@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ;
|
|||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ ] [ now timestamp>rfc3339 drop ] unit-test
|
||||
[ ] [ now timestamp>rfc822 drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: calendar.format
|
||||
USING: math math.parser kernel sequences io calendar
|
||||
accessors arrays io.streams.string combinators accessors ;
|
||||
accessors arrays io.streams.string combinators accessors
|
||||
combinators.cleave ;
|
||||
IN: calendar.format
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
|
|
@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- )
|
|||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
: (write-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
{
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
|
||||
dup instant <=> {
|
||||
{ [ dup 0 = ] [ 2drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
: timestamp>rfc822 ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
|
|
@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- )
|
|||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
>gmt timestamp>rfc822 ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
: (write-rfc3339-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 CHAR: : write1 ]
|
||||
[ minute>> write-00 ] bi ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( duration -- )
|
||||
dup instant <=> {
|
||||
{ [ dup 0 = ] [ 2drop "Z" write ] }
|
||||
{ [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup year>> number>string write CHAR: - write1
|
||||
dup month>> write-00 CHAR: - write1
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
USING: alien alien.c-types arrays calendar.backend
|
||||
kernel structs math unix.time namespaces ;
|
||||
kernel structs math unix.time namespaces ;
|
||||
|
||||
IN: calendar.unix
|
||||
|
||||
|
|
@ -8,11 +7,11 @@ TUPLE: unix-calendar ;
|
|||
|
||||
T{ unix-calendar } calendar-backend set-global
|
||||
|
||||
: get-time
|
||||
: get-time ( -- alien )
|
||||
f time <uint> localtime ;
|
||||
|
||||
: timezone-name
|
||||
: timezone-name ( -- string )
|
||||
get-time tm-zone ;
|
||||
|
||||
M: unix-calendar gmt-offset
|
||||
get-time tm-gmtoff 3600 / ;
|
||||
M: unix-calendar gmt-offset ( -- hours minutes seconds )
|
||||
get-time tm-gmtoff 3600 /mod 60 /mod ;
|
||||
|
|
|
|||
|
|
@ -8,8 +8,14 @@ T{ windows-calendar } calendar-backend set-global
|
|||
|
||||
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
|
||||
|
||||
M: windows-calendar gmt-offset ( -- float )
|
||||
M: windows-calendar gmt-offset ( -- hours minutes seconds )
|
||||
"TIME_ZONE_INFORMATION" <c-object>
|
||||
dup GetTimeZoneInformation
|
||||
TIME_ZONE_ID_INVALID = [ win32-error ] when
|
||||
TIME_ZONE_INFORMATION-Bias 60 / neg ;
|
||||
dup GetTimeZoneInformation {
|
||||
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
|
||||
{ [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
|
||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
|
||||
{ [ dup TIME_ZONE_ID_DAYLIGHT = ] [
|
||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ]
|
||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi
|
||||
] }
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: channels.remote
|
|||
PRIVATE>
|
||||
|
||||
: publish ( channel -- id )
|
||||
random-256 dup >r remote-channels set-at r> ;
|
||||
256 random-bits dup >r remote-channels set-at r> ;
|
||||
|
||||
: get-channel ( id -- channel )
|
||||
remote-channels at ;
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at
|
|||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get at
|
||||
[ ] [ "No such method: " swap append throw ] ?if ;
|
||||
[ ] [ "No such method: " prepend throw ] ?if ;
|
||||
|
||||
: make-dip ( quot n -- quot' )
|
||||
dup
|
||||
|
|
@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot )
|
|||
! Runtime introspection
|
||||
: (objc-class) ( string word -- class )
|
||||
dupd execute
|
||||
[ ] [ "No such class: " swap append throw ] ?if ; inline
|
||||
[ ] [ "No such class: " prepend throw ] ?if ; inline
|
||||
|
||||
: objc-class ( string -- class )
|
||||
\ objc_getClass (objc-class) ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,8 @@ IN: cocoa.windows
|
|||
: <ViewWindow> ( view rect -- window )
|
||||
<NSWindow> [ swap -> setContentView: ] keep
|
||||
dup dup -> contentView -> setInitialFirstResponder:
|
||||
dup 1 -> setAcceptsMouseMovedEvents: ;
|
||||
dup 1 -> setAcceptsMouseMovedEvents:
|
||||
dup 0 -> setReleasedWhenClosed: ;
|
||||
|
||||
: window-content-rect ( window -- rect )
|
||||
NSWindow over -> frame rot -> styleMask
|
||||
|
|
|
|||
|
|
@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- )
|
|||
|
||||
: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
|
||||
|
||||
: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline
|
||||
|
||||
: tri* ( x y z p q r -- p(x) q(y) r(z) )
|
||||
>r rot >r bi* r> r> call ; inline
|
||||
|
||||
|
|
@ -68,7 +70,7 @@ MACRO: spread ( seq -- )
|
|||
dup
|
||||
[ drop [ >r ] ] map concat
|
||||
swap
|
||||
[ [ r> ] swap append ] map concat
|
||||
[ [ r> ] prepend ] map concat
|
||||
append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -8,13 +8,6 @@ continuations ;
|
|||
|
||||
IN: combinators.lib
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: generate ( generator predicate -- obj )
|
||||
#! Call 'generator' until the result satisfies 'predicate'.
|
||||
[ slip over slip ] 2keep
|
||||
roll [ 2drop ] [ rot drop generate ] if ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Generalized versions of core combinators
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -82,11 +75,11 @@ MACRO: && ( quots -- ? )
|
|||
[ [ not ] append [ f ] ] t short-circuit ;
|
||||
|
||||
MACRO: <-&& ( quots -- )
|
||||
[ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ nip ] append ;
|
||||
|
||||
MACRO: <--&& ( quots -- )
|
||||
[ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
|
||||
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||
[ 2nip ] append ;
|
||||
|
||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
||||
|
|
@ -137,11 +130,14 @@ MACRO: map-call-with ( quots -- )
|
|||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
|
||||
: (make-call-with2) ( quots -- quot )
|
||||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
|
||||
MACRO: map-call-with2 ( quots -- )
|
||||
[ (make-call-with2) ] keep length [ narray ] curry append ;
|
||||
[
|
||||
[ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
|
||||
[ 2drop ] append
|
||||
] keep length [ narray ] curry append ;
|
||||
|
||||
MACRO: map-exec-with ( words -- )
|
||||
[ 1quotation ] map [ map-call-with ] curry ;
|
||||
|
|
@ -163,5 +159,19 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
|
|||
: and? ( obj quot1 quot2 -- ? )
|
||||
>r keep r> rot [ call ] [ 2drop f ] if ; inline
|
||||
|
||||
MACRO: multikeep ( word out-indexes -- ... )
|
||||
[
|
||||
dup >r [ \ npick \ >r 3array % ] each
|
||||
%
|
||||
r> [ drop \ r> , ] each
|
||||
] [ ] make ;
|
||||
|
||||
: retry ( quot n -- )
|
||||
[ drop ] rot compose attempt-all ; inline
|
||||
|
||||
: do-while ( pred body tail -- )
|
||||
>r tuck 2slip r> while ;
|
||||
|
||||
: generate ( generator predicate -- obj )
|
||||
[ dup ] swap [ dup [ nip ] unless not ] 3compose
|
||||
swap [ ] do-while ;
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ M: thread send ( message thread -- )
|
|||
TUPLE: synchronous data sender tag ;
|
||||
|
||||
: <synchronous> ( data -- sync )
|
||||
self random-256 synchronous construct-boa ;
|
||||
self 256 random-bits synchronous construct-boa ;
|
||||
|
||||
TUPLE: reply data tag ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
|
|||
dup <CFBundle> [
|
||||
CFBundleLoadExecutable drop
|
||||
] [
|
||||
"Cannot load bundled named " swap append throw
|
||||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
|
|
|||
|
|
@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks
|
|||
: event-stream-counter \ event-stream-counter counter ;
|
||||
|
||||
[
|
||||
H{ } clone event-stream-callbacks set-global
|
||||
event-stream-callbacks global
|
||||
[ [ drop expired? not ] assoc-subset ] change-at
|
||||
1 \ event-stream-counter set-global
|
||||
] "core-foundation" add-init-hook
|
||||
|
||||
|
|
|
|||
|
|
@ -446,7 +446,7 @@ M: cpu reset ( cpu -- )
|
|||
SYMBOL: rom-root
|
||||
|
||||
: rom-dir ( -- string )
|
||||
rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
|
||||
rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
|
||||
|
||||
: load-rom* ( seq cpu -- )
|
||||
#! 'seq' is an array of arrays. Each array contains
|
||||
|
|
@ -455,7 +455,7 @@ SYMBOL: rom-root
|
|||
#! file path shoul dbe relative to the '/roms' resource path.
|
||||
rom-dir [
|
||||
cpu-ram [
|
||||
swap first2 rom-dir swap path+ binary [
|
||||
swap first2 rom-dir prepend-path binary [
|
||||
swap (load-rom)
|
||||
] with-file-reader
|
||||
] curry each
|
||||
|
|
@ -1027,14 +1027,14 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADC-R,(RR)-instruction ( -- parser )
|
||||
"ADC-R,(RR)" "ADC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SBC-R,N-instruction ( -- parser )
|
||||
"SBC-R,N" "SBC" complex-instruction
|
||||
|
|
@ -1047,14 +1047,14 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SBC-R,(RR)-instruction ( -- parser )
|
||||
"SBC-R,(RR)" "SBC" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: SUB-R-instruction ( -- parser )
|
||||
"SUB-R" "SUB" complex-instruction
|
||||
|
|
@ -1082,21 +1082,21 @@ SYMBOL: $4
|
|||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADD-RR,RR-instruction ( -- parser )
|
||||
"ADD-RR,RR" "ADD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: ADD-R,(RR)-instruction ( -- parser )
|
||||
"ADD-R,(RR)" "ADD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,NN-instruction
|
||||
#! LD BC,nn
|
||||
|
|
@ -1124,28 +1124,28 @@ SYMBOL: $4
|
|||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,R-instruction
|
||||
"LD-R,R" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,RR-instruction
|
||||
"LD-RR,RR" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,(RR)-instruction
|
||||
"LD-R,(RR)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-(NN),RR-instruction
|
||||
"LD-(NN),RR" "LD" complex-instruction
|
||||
|
|
@ -1194,14 +1194,14 @@ SYMBOL: $4
|
|||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: EX-RR,RR-instruction
|
||||
"EX-RR,RR" "EX" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: 8080-generator-parser
|
||||
NOP-instruction
|
||||
|
|
|
|||
|
|
@ -1,36 +0,0 @@
|
|||
USING: kernel math sequences namespaces crypto math-contrib ;
|
||||
IN: crypto-internals
|
||||
|
||||
! TODO: take (log log M) bits instead of 1 bit
|
||||
! Blum Blum Shub, M = pq
|
||||
TUPLE: bbs x n ;
|
||||
|
||||
: generate-bbs-primes ( numbits -- p q )
|
||||
#! two primes congruent to 3 (mod 4)
|
||||
dup [ random-miller-rabin-prime==3(mod4) ] 2apply ;
|
||||
|
||||
IN: crypto
|
||||
: make-bbs ( numbits -- blum-blum-shub )
|
||||
#! returns a Blum-Blum-Shub tuple
|
||||
generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
|
||||
|
||||
IN: crypto-internals
|
||||
SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global
|
||||
|
||||
: next-bbs-bit ( bbs -- bit )
|
||||
#! x = x^2 mod n, return low bit of calculated x
|
||||
[ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep
|
||||
[ set-bbs-x ] keep bbs-x 1 bitand ;
|
||||
|
||||
SYMBOL: temp-bbs
|
||||
: (bbs-bits) ( numbits bbs -- n )
|
||||
temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
|
||||
|
||||
IN: crypto
|
||||
: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
|
||||
: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;
|
||||
: random-bytes ( numbits -- n ) 8 * random-bits ;
|
||||
: random ( n -- n )
|
||||
! #! Cryptographically secure random number using Blum-Blum-Shub 256
|
||||
[ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
|
||||
|
||||
|
|
@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
|
|||
TUPLE: statement handle sql in-params out-params bind-params bound? ;
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
TUPLE: nonthrowable-statement ;
|
||||
: make-nonthrowable ( obj -- obj' )
|
||||
dup sequence? [
|
||||
[ make-nonthrowable ] map
|
||||
] [
|
||||
nonthrowable-statement construct-delegate
|
||||
] if ;
|
||||
|
||||
MIXIN: throwable-statement
|
||||
INSTANCE: statement throwable-statement
|
||||
INSTANCE: simple-statement throwable-statement
|
||||
INSTANCE: prepared-statement throwable-statement
|
||||
|
||||
TUPLE: result-set sql in-params out-params handle n max ;
|
||||
: <statement> ( sql in out -- statement )
|
||||
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
|
||||
|
|
@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
|
|||
GENERIC: advance-row ( result-set -- )
|
||||
GENERIC: more-rows? ( result-set -- ? )
|
||||
|
||||
: execute-statement ( statement -- )
|
||||
GENERIC: execute-statement ( statement -- )
|
||||
|
||||
M: throwable-statement execute-statement ( statement -- )
|
||||
dup sequence? [
|
||||
[ execute-statement ] each
|
||||
] [
|
||||
query-results dispose
|
||||
] if ;
|
||||
|
||||
M: nonthrowable-statement execute-statement ( statement -- )
|
||||
dup sequence? [
|
||||
[ execute-statement ] each
|
||||
] [
|
||||
[ query-results dispose ] [ 2drop ] recover
|
||||
] if ;
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
swap >>bind-params
|
||||
[ bind-statement* ] keep
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ IN: db.postgresql.lib
|
|||
sql-spec-type {
|
||||
{ FACTOR-BLOB [
|
||||
dup [
|
||||
binary [ serialize ] with-byte-writer
|
||||
object>bytes
|
||||
malloc-byte-array/length ] [ 0 ] if ] }
|
||||
{ BLOB [
|
||||
dup [ malloc-byte-array/length ] [ 0 ] if ] }
|
||||
|
|
@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
{ BLOB [ pq-get-blob ] }
|
||||
{ FACTOR-BLOB [
|
||||
pq-get-blob
|
||||
dup [ binary [ deserialize ] with-byte-reader ] when ] }
|
||||
dup [ bytes>object ] when ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
! PQgetlength PQgetisnull
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ IN: db.postgresql
|
|||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
TUPLE: postgresql-statement ;
|
||||
INSTANCE: postgresql-statement throwable-statement
|
||||
TUPLE: postgresql-result-set ;
|
||||
: <postgresql-statement> ( statement in out -- postgresql-statement )
|
||||
<statement>
|
||||
|
|
@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
|
|||
");" 0%
|
||||
] postgresql-make ;
|
||||
|
||||
M: postgresql-db <insert-assigned-statement> ( class -- statement )
|
||||
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ IN: db.sqlite.lib
|
|||
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
|
||||
{ BLOB [ sqlite-bind-blob-by-name ] }
|
||||
{ FACTOR-BLOB [
|
||||
binary [ serialize ] with-byte-writer
|
||||
object>bytes
|
||||
sqlite-bind-blob-by-name
|
||||
] }
|
||||
{ +native-id+ [ sqlite-bind-int-by-name ] }
|
||||
|
|
@ -106,6 +106,8 @@ IN: db.sqlite.lib
|
|||
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
|
||||
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
|
||||
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
|
||||
: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
|
||||
|
||||
: sqlite-column-blob ( handle index -- byte-array/f )
|
||||
[ sqlite3_column_bytes ] 2keep
|
||||
|
|
@ -119,6 +121,7 @@ IN: db.sqlite.lib
|
|||
dup array? [ first ] when
|
||||
{
|
||||
{ +native-id+ [ sqlite3_column_int64 ] }
|
||||
{ +random-id+ [ sqlite3_column_int64 ] }
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
|
|
@ -131,7 +134,7 @@ IN: db.sqlite.lib
|
|||
{ BLOB [ sqlite-column-blob ] }
|
||||
{ FACTOR-BLOB [
|
||||
sqlite-column-blob
|
||||
dup [ binary [ deserialize ] with-byte-reader ] when
|
||||
dup [ bytes>object ] when
|
||||
] }
|
||||
! { NULL [ 2drop f ] }
|
||||
[ no-sql-type ]
|
||||
|
|
@ -140,7 +143,7 @@ IN: db.sqlite.lib
|
|||
: sqlite-row ( handle -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
: sqlite-step-has-more-rows? ( step-result -- bool )
|
||||
: sqlite-step-has-more-rows? ( prepared -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop t
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
|
|||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types combinators
|
||||
combinators.cleave io namespaces.lib ;
|
||||
USE: tools.walker
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
|
@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
|
|||
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
|
||||
|
||||
TUPLE: sqlite-statement ;
|
||||
INSTANCE: sqlite-statement throwable-statement
|
||||
|
||||
TUPLE: sqlite-result-set has-more? ;
|
||||
|
||||
M: sqlite-db <simple-statement> ( str in out -- obj )
|
||||
|
|
@ -33,12 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
|
|||
set-statement-in-params
|
||||
set-statement-out-params
|
||||
} statement construct
|
||||
db get db-handle over statement-sql sqlite-prepare
|
||||
over set-statement-handle
|
||||
sqlite-statement construct-delegate ;
|
||||
|
||||
: sqlite-maybe-prepare ( statement -- statement )
|
||||
dup statement-handle [
|
||||
[
|
||||
delegate
|
||||
db get db-handle over statement-sql sqlite-prepare
|
||||
swap set-statement-handle
|
||||
] keep
|
||||
] unless ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
statement-handle sqlite-finalize ;
|
||||
statement-handle
|
||||
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
f swap set-result-set-handle ;
|
||||
|
|
@ -46,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
|
|||
: sqlite-bind ( triples handle -- )
|
||||
swap [ first3 sqlite-bind-type ] with each ;
|
||||
|
||||
: reset-statement ( statement -- ) statement-handle sqlite-reset ;
|
||||
: reset-statement ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
statement-handle sqlite-reset ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( statement -- )
|
||||
sqlite-maybe-prepare
|
||||
dup statement-bound? [ dup reset-statement ] when
|
||||
[ statement-bind-params ] [ statement-handle ] bi
|
||||
sqlite-bind ;
|
||||
|
|
@ -57,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
|
|||
[
|
||||
statement-in-params
|
||||
[
|
||||
[ sql-spec-column-name ":" swap append ]
|
||||
[ sql-spec-column-name ":" prepend ]
|
||||
[ sql-spec-slot-name rot get-slot-named ]
|
||||
[ sql-spec-type ] tri 3array
|
||||
] with map
|
||||
|
|
@ -89,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
|
|||
sqlite-result-set-has-more? ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
sqlite-maybe-prepare
|
||||
dup statement-handle sqlite-result-set <result-set>
|
||||
dup advance-row ;
|
||||
|
||||
|
|
@ -125,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
|||
");" 0%
|
||||
] sqlite-make ;
|
||||
|
||||
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
|
||||
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
|
||||
<insert-native-statement> ;
|
||||
|
||||
: where-primary-key% ( specs -- )
|
||||
|
|
@ -158,7 +173,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
|
|||
! : select-sequence ( seq name -- ) ;
|
||||
|
||||
M: sqlite-db bind% ( spec -- )
|
||||
dup 1, sql-spec-column-name ":" swap append 0% ;
|
||||
dup 1, sql-spec-column-name ":" prepend 0% ;
|
||||
|
||||
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
||||
[
|
||||
|
|
@ -175,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable )
|
|||
H{
|
||||
{ +native-id+ "primary key" }
|
||||
{ +assigned-id+ "primary key" }
|
||||
{ +random-id+ "primary key" }
|
||||
! { +nonnative-id+ "primary key" }
|
||||
{ +autoincrement+ "autoincrement" }
|
||||
{ +unique+ "unique" }
|
||||
{ +default+ "default" }
|
||||
|
|
@ -193,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- str' )
|
|||
M: sqlite-db type-table ( -- assoc )
|
||||
H{
|
||||
{ +native-id+ "integer primary key" }
|
||||
{ +random-id+ "integer primary key" }
|
||||
{ INTEGER "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "text" }
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: db.tuples.tests
|
|||
TUPLE: person the-id the-name the-number the-real
|
||||
ts date time blob factor-blob ;
|
||||
|
||||
: <person> ( name age real ts date time blob -- person )
|
||||
: <person> ( name age real ts date time blob factor-blob -- person )
|
||||
{
|
||||
set-person-the-name
|
||||
set-person-the-number
|
||||
|
|
@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
: test-postgresql ( -- )
|
||||
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
|
||||
! [ native-person-schema test-tuples ] test-postgresql
|
||||
! [ assigned-person-schema test-tuples ] test-postgresql
|
||||
: test-repeated-insert
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
[ person1 get insert-tuple ] must-fail ;
|
||||
|
||||
TUPLE: serialize-me id data ;
|
||||
|
||||
|
|
@ -240,8 +240,33 @@ TUPLE: exam id name score ;
|
|||
|
||||
! [ test-ranges ] test-sqlite
|
||||
|
||||
\ insert-tuple must-infer
|
||||
\ update-tuple must-infer
|
||||
\ delete-tuple must-infer
|
||||
\ select-tuple must-infer
|
||||
\ define-persistent must-infer
|
||||
TUPLE: secret n message ;
|
||||
C: <secret> secret
|
||||
|
||||
: test-random-id
|
||||
secret "SECRET"
|
||||
{
|
||||
{ "n" "ID" +random-id+ }
|
||||
{ "message" "MESSAGE" TEXT }
|
||||
} define-persistent
|
||||
|
||||
[ ] [ secret ensure-table ] unit-test
|
||||
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
|
||||
[ ] [ T{ secret } select-tuples ] unit-test
|
||||
;
|
||||
|
||||
|
||||
|
||||
! [ test-random-id ] test-sqlite
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
! [ assigned-person-schema test-repeated-insert ] test-sqlite
|
||||
! [ native-person-schema test-tuples ] test-postgresql
|
||||
! [ assigned-person-schema test-tuples ] test-postgresql
|
||||
! [ assigned-person-schema test-repeated-insert ] test-postgresql
|
||||
|
||||
! \ insert-tuple must-infer
|
||||
! \ update-tuple must-infer
|
||||
! \ delete-tuple must-infer
|
||||
! \ select-tuple must-infer
|
||||
! \ define-persistent must-infer
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
|
|||
HOOK: drop-sql-statement db ( class -- obj )
|
||||
|
||||
HOOK: <insert-native-statement> db ( class -- obj )
|
||||
HOOK: <insert-assigned-statement> db ( class -- obj )
|
||||
HOOK: <insert-nonnative-statement> db ( class -- obj )
|
||||
|
||||
HOOK: <update-tuple-statement> db ( class -- obj )
|
||||
HOOK: <update-tuples-statement> db ( class -- obj )
|
||||
|
|
@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
|||
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
[ dup drop-table ] ignore-errors create-table ;
|
||||
[
|
||||
drop-sql-statement make-nonthrowable
|
||||
[ execute-statement ] with-disposals
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: insert-native ( tuple -- )
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-native-statement> ] cache
|
||||
[ bind-tuple ] 2keep insert-tuple* ;
|
||||
|
||||
: insert-assigned ( tuple -- )
|
||||
: insert-nonnative ( tuple -- )
|
||||
! TODO logic here for unique ids
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-assigned-statement> ] cache
|
||||
db get db-insert-statements [ <insert-nonnative-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
dup class db-columns find-primary-key assigned-id? [
|
||||
insert-assigned
|
||||
dup class db-columns find-primary-key nonnative-id? [
|
||||
insert-nonnative
|
||||
] [
|
||||
insert-native
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations sequences.deep sequences.lib
|
||||
words namespaces tools.walker slots slots.private classes
|
||||
mirrors tuples combinators calendar.format symbols ;
|
||||
mirrors tuples combinators calendar.format symbols
|
||||
singleton ;
|
||||
IN: db.types
|
||||
|
||||
HOOK: modifier-table db ( -- hash )
|
||||
|
|
@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash )
|
|||
|
||||
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
|
||||
|
||||
SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
|
||||
+serial+ +unique+ +default+ +null+ +not-null+
|
||||
SINGLETON: +native-id+
|
||||
SINGLETON: +assigned-id+
|
||||
SINGLETON: +random-id+
|
||||
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
|
||||
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
|
||||
|
||||
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
||||
+foreign-id+ +has-many+ ;
|
||||
|
||||
: (primary-key?) ( obj -- ? )
|
||||
{ +native-id+ +assigned-id+ } member? ;
|
||||
|
||||
: primary-key? ( spec -- ? )
|
||||
sql-spec-primary-key (primary-key?) ;
|
||||
sql-spec-primary-key +primary-key+? ;
|
||||
|
||||
: native-id? ( spec -- ? )
|
||||
sql-spec-primary-key +native-id+? ;
|
||||
|
||||
: nonnative-id? ( spec -- ? )
|
||||
sql-spec-primary-key +nonnative-id+? ;
|
||||
|
||||
: normalize-spec ( spec -- )
|
||||
dup sql-spec-type dup (primary-key?) [
|
||||
dup sql-spec-type dup +primary-key+? [
|
||||
swap set-sql-spec-primary-key
|
||||
] [
|
||||
drop dup sql-spec-modifiers [
|
||||
(primary-key?)
|
||||
+primary-key+?
|
||||
] deep-find
|
||||
[ swap set-sql-spec-primary-key ] [ drop ] if*
|
||||
] if ;
|
||||
|
|
@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
|
|||
: find-primary-key ( specs -- obj )
|
||||
[ sql-spec-primary-key ] find nip ;
|
||||
|
||||
: native-id? ( spec -- ? )
|
||||
sql-spec-primary-key +native-id+ = ;
|
||||
|
||||
: assigned-id? ( spec -- ? )
|
||||
sql-spec-primary-key +assigned-id+ = ;
|
||||
|
||||
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
|
||||
|
||||
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
|
||||
|
|
@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ;
|
|||
dup number? [ number>string ] when ;
|
||||
|
||||
: maybe-remove-id ( specs -- obj )
|
||||
[ native-id? not ] subset ;
|
||||
[ +native-id+? not ] subset ;
|
||||
|
||||
: remove-relations ( specs -- newcolumns )
|
||||
[ relation? not ] subset ;
|
||||
|
|
@ -124,7 +127,7 @@ TUPLE: no-sql-modifier ;
|
|||
: modifiers ( spec -- str )
|
||||
sql-spec-modifiers
|
||||
[ lookup-modifier ] map " " join
|
||||
dup empty? [ " " swap append ] unless ;
|
||||
dup empty? [ " " prepend ] unless ;
|
||||
|
||||
HOOK: bind% db ( spec -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: delegate
|
|||
swap { } like "protocol-words" set-word-prop ;
|
||||
|
||||
: PROTOCOL:
|
||||
CREATE dup reset-generic dup define-symbol
|
||||
CREATE-WORD dup define-symbol
|
||||
parse-definition swap define-protocol ; parsing
|
||||
|
||||
PREDICATE: word protocol "protocol-words" word-prop ;
|
||||
|
|
@ -27,11 +27,11 @@ M: tuple-class group-words
|
|||
swap [ slot-spec-writer ] map append ;
|
||||
|
||||
: define-consult-method ( word class quot -- )
|
||||
pick add spin define-method ;
|
||||
pick add >r swap create-method r> define ;
|
||||
|
||||
: define-consult ( class group quot -- )
|
||||
>r group-words r>
|
||||
swapd [ define-consult-method ] 2curry each ;
|
||||
>r group-words swap r>
|
||||
[ define-consult-method ] 2curry each ;
|
||||
|
||||
: CONSULT:
|
||||
scan-word scan-word parse-definition swapd define-consult ; parsing
|
||||
|
|
@ -39,7 +39,7 @@ M: tuple-class group-words
|
|||
: define-mimic ( group mimicker mimicked -- )
|
||||
>r >r group-words r> r> [
|
||||
pick "methods" word-prop at dup
|
||||
[ "method-def" word-prop spin define-method ]
|
||||
[ >r swap create-method r> word-def define ]
|
||||
[ 3drop ] if
|
||||
] 2curry each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ TUPLE: document locs ;
|
|||
0 swap [ append ] change-nth ;
|
||||
|
||||
: append-last ( str seq -- )
|
||||
[ length 1- ] keep [ swap append ] change-nth ;
|
||||
[ length 1- ] keep [ prepend ] change-nth ;
|
||||
|
||||
: loc-col/str ( loc document -- str col )
|
||||
>r first2 swap r> nth swap ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: editors.editpadpro
|
|||
|
||||
: editpadpro-path
|
||||
\ editpadpro-path get-global [
|
||||
program-files "JGsoft" path+
|
||||
program-files "JGsoft" append-path
|
||||
t [ >lower "editpadpro.exe" tail? ] find-file
|
||||
] unless* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.editplus
|
|||
|
||||
: editplus-path ( -- path )
|
||||
\ editplus-path get-global [
|
||||
program-files "\\EditPlus 2\\editplus.exe" path+
|
||||
program-files "\\EditPlus 2\\editplus.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: editplus ( file line -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.emeditor
|
|||
|
||||
: emeditor-path ( -- path )
|
||||
\ emeditor-path get-global [
|
||||
program-files "\\EmEditor\\EmEditor.exe" path+
|
||||
program-files "\\EmEditor\\EmEditor.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: emeditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -4,6 +4,6 @@ IN: editors.gvim.windows
|
|||
|
||||
M: windows-io gvim-path
|
||||
\ gvim-path get-global [
|
||||
program-files "vim" path+
|
||||
program-files "vim" append-path
|
||||
t [ "gvim.exe" tail? ] find-file
|
||||
] unless* ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ io.encodings.utf8 ;
|
|||
IN: editors.jedit
|
||||
|
||||
: jedit-server-info ( -- port auth )
|
||||
home "/.jedit/server" path+ ascii [
|
||||
home "/.jedit/server" append-path ascii [
|
||||
readln drop
|
||||
readln string>number
|
||||
readln string>number
|
||||
|
|
@ -32,7 +32,7 @@ IN: editors.jedit
|
|||
] with-stream ;
|
||||
|
||||
: jedit-location ( file line -- )
|
||||
number>string "+line:" swap append 2array
|
||||
number>string "+line:" prepend 2array
|
||||
make-jedit-request send-jedit-request ;
|
||||
|
||||
: jedit-file ( file -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: editors.notepadpp
|
|||
|
||||
: notepadpp-path
|
||||
\ notepadpp-path get-global [
|
||||
program-files "notepad++\\notepad++.exe" path+
|
||||
program-files "notepad++\\notepad++.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: notepadpp ( file line -- )
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: editors.scite
|
|||
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "wscite\\SciTE.exe" path+
|
||||
program-files "wscite\\SciTE.exe" append-path
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue