steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Imported https://downloads.factorcode.org/releases/0.97/factor-src-0.97.zip

release import-0.97
nomennescio 2019-10-18 15:06:23 +02:00
parent c4114f4419 eb3ca17974
commit ccbc0c6a6f
1514 changed files with 48069 additions and 24214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Factor.app/Contents/Info.plist
View File

@ -32,7 +32,7 @@
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>CFBundleVersion</key>
<string>0.96</string>
<string>0.97</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2013 Factor developers</string>
<key>NSServices</key>

22
GNUmakefile
View File

@ -1,8 +1,5 @@
ifdef CONFIG
CC = gcc
CPP = g++
VERSION = 0.96
VERSION = 0.97
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
@ -14,7 +11,7 @@ ifdef CONFIG
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
else
CFLAGS += -O3
CFLAGS += -O3 -g
endif
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
@ -26,7 +23,6 @@ ifdef CONFIG
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callbacks.o \
vm/callstack.o \
@ -99,13 +95,10 @@ ifdef CONFIG
vm/data_heap.hpp \
vm/code_heap.hpp \
vm/gc.hpp \
vm/debug.hpp \
vm/strings.hpp \
vm/words.hpp \
vm/float_bits.hpp \
vm/io.hpp \
vm/image.hpp \
vm/alien.hpp \
vm/callbacks.hpp \
vm/dispatch.hpp \
vm/entry_points.hpp \
@ -124,7 +117,6 @@ ifdef CONFIG
vm/aging_collector.hpp \
vm/to_tenured_collector.hpp \
vm/code_block_visitor.hpp \
vm/compaction.hpp \
vm/full_collector.hpp \
vm/arrays.hpp \
vm/math.hpp \
@ -215,11 +207,11 @@ $(ENGINE): $(DLL_OBJS)
factor-lib: $(ENGINE)
factor: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \
$(TOOLCHAIN_PREFIX)$(CXX) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \
$(TOOLCHAIN_PREFIX)$(CXX) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
@ -234,16 +226,16 @@ vm/ffi_test.o: vm/ffi_test.c
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS)
$(TOOLCHAIN_PREFIX)$(CPP) -c -x c++-header $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CXX) -c -x c++-header $(CFLAGS) -o $@ $<
%.o: %.cpp vm/master.hpp.gch
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) -o $@ $<
%.o: %.S
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
%.o: %.mm vm/master.hpp.gch
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) -o $@ $<
.SUFFIXES: .mm

32
Nmakefile
View File

@ -6,17 +6,28 @@ BOOTIMAGE_VERSION = latest
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
!ENDIF
CL_FLAGS_VISTA = /D_WIN32_WINNT=0x0600
!IF "$(PLATFORM)" == "x86-32"
LINK_FLAGS = $(LINK_FLAGS) /safeseh
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
!ELSEIF "$(PLATFORM)" == "x86-32-vista"
LINK_FLAGS = $(LINK_FLAGS) /safeseh
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
!ELSEIF "$(PLATFORM)" == "x86-64"
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
!ELSEIF "$(PLATFORM)" == "x86-64-vista"
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
!ENDIF
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
!ENDIF
ML_FLAGS = /nologo /safeseh
@ -29,7 +40,6 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\alien.obj \
vm\arrays.obj \
vm\bignum.obj \
vm\booleans.obj \
vm\byte_arrays.obj \
vm\callbacks.obj \
vm\callstack.obj \
@ -104,6 +114,8 @@ default:
@echo Where platform is one of:
@echo x86-32
@echo x86-64
@echo x86-32-vista
@echo x86-64-vista
@exit 1
x86-32:
@ -112,6 +124,12 @@ x86-32:
x86-64:
nmake /nologo PLATFORM=x86-64 /f Nmakefile all
x86-32-vista:
nmake /nologo PLATFORM=x86-32-vista /f Nmakefile all
x86-64-vista:
nmake /nologo PLATFORM=x86-64-vista /f Nmakefile all
clean:
del vm\*.obj
if exist factor.lib del factor.lib
@ -121,6 +139,6 @@ clean:
if exist factor.dll del factor.dll
if exist factor.dll.lib del factor.dll.lib
.PHONY: all default x86-32 x86-64 clean
.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean
.SUFFIXES: .rs

10
basis/alien/c-types/c-types.factor
View File

@ -318,6 +318,7 @@ M: pointer lookup-c-type
\ double typedef
cell 8 = [
! 64bit-vm int
<c-type>
fixnum >>class
fixnum >>boxed-class
@ -332,6 +333,7 @@ M: pointer lookup-c-type
[ >fixnum ] >>unboxer-quot
\ int typedef
! 64bit-vm uint
<c-type>
fixnum >>class
fixnum >>boxed-class
@ -345,6 +347,7 @@ M: pointer lookup-c-type
[ >fixnum ] >>unboxer-quot
\ uint typedef
! 64bit-vm longlong
<c-type>
integer >>class
integer >>boxed-class
@ -355,10 +358,11 @@ M: pointer lookup-c-type
8 >>align
8 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
"to_signed_8" >>unboxer
[ >integer ] >>unboxer-quot
\ longlong typedef
! 64bit-vm ulonglong
<c-type>
integer >>class
integer >>boxed-class
@ -386,6 +390,7 @@ M: pointer lookup-c-type
\ ulonglong lookup-c-type \ uintptr_t typedef
\ ulonglong lookup-c-type \ size_t typedef
] [
! 32bit-vm int
<c-type>
integer >>class
integer >>boxed-class
@ -400,6 +405,7 @@ M: pointer lookup-c-type
[ >integer ] >>unboxer-quot
\ int typedef
! 32bit-vm uint
<c-type>
integer >>class
integer >>boxed-class
@ -413,6 +419,7 @@ M: pointer lookup-c-type
[ >integer ] >>unboxer-quot
\ uint typedef
! 32bit-vm longlong
<long-long-type>
integer >>class
integer >>boxed-class
@ -426,6 +433,7 @@ M: pointer lookup-c-type
[ >integer ] >>unboxer-quot
\ longlong typedef
! 32bit-vm ulonglong
<long-long-type>
integer >>class
integer >>boxed-class

2
basis/alien/data/data.factor
View File

@ -8,7 +8,7 @@ QUALIFIED: math
IN: alien.data
: <ref> ( value c-type -- c-ptr )
[ heap-size <byte-array> ] keep
[ heap-size (byte-array) ] keep
'[ 0 _ set-alien-value ] keep ; inline
: deref ( c-ptr c-type -- value )

10
basis/alien/endian/endian.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien alien.accessors alien.c-types alien.data
classes.struct.private combinators compiler.units endian fry
generalizations kernel macros math namespaces sequences words
arrays slots math.bitwise ;
QUALIFIED-WITH: alien.c-types ac
QUALIFIED-WITH: alien.c-types c
IN: alien.endian
ERROR: invalid-signed-conversion n ;
@ -12,7 +12,7 @@ ERROR: invalid-signed-conversion n ;
: convert-signed-quot ( n -- quot )
{
{ 1 [ [ char <ref> char deref ] ] }
{ 2 [ [ ac:short <ref> ac:short deref ] ] }
{ 2 [ [ c:short <ref> c:short deref ] ] }
{ 4 [ [ int <ref> int deref ] ] }
{ 8 [ [ longlong <ref> longlong deref ] ] }
[ invalid-signed-conversion ]
@ -47,7 +47,7 @@ ERROR: unknown-endian-c-type symbol ;
: endian-c-type>c-type-symbol ( symbol -- symbol' )
{
{ [ dup { ule16 ube16 } member? ] [ drop ushort ] }
{ [ dup { le16 be16 } member? ] [ drop ac:short ] }
{ [ dup { le16 be16 } member? ] [ drop c:short ] }
{ [ dup { ule32 ube32 } member? ] [ drop uint ] }
{ [ dup { le32 be32 } member? ] [ drop int ] }
{ [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
@ -111,7 +111,7 @@ ERROR: unknown-endian-c-type symbol ;
! otherwise return the opposite of our endianness
: endian-slot ( endian c-type pair -- endian-slot )
[ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
ERROR: unsupported-endian-type endian slot ;
: slot>endian-slot ( endian slot -- endian-slot )
@ -121,7 +121,7 @@ ERROR: unsupported-endian-type endian slot ;
{
{ [ dup char = ] [ 2drop char ] }
{ [ dup uchar = ] [ 2drop uchar ] }
{ [ dup ac:short = ] [ { le16 be16 } endian-slot ] }
{ [ dup c:short = ] [ { le16 be16 } endian-slot ] }
{ [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
{ [ dup int = ] [ { le32 be32 } endian-slot ] }
{ [ dup uint = ] [ { ule32 ube32 } endian-slot ] }

8
basis/alien/enums/enums.factor
View File

@ -1,7 +1,7 @@
! (c)2010 Joe Groff, Erik Charlebois bsd license
USING: accessors alien.c-types arrays combinators delegate fry
generic.parser kernel macros math parser sequences words words.symbol
classes.singleton assocs ;
USING: accessors alien.c-types arrays assocs classes.singleton
combinators delegate fry kernel macros math parser sequences
words ;
IN: alien.enums
<PRIVATE
@ -52,6 +52,6 @@ PRIVATE>
: define-enum ( word base-type members -- )
[ (define-enum) ]
[ [ define-enum-value ] assoc-each ] bi ;
PREDICATE: enum-c-type-word < c-type-word
"c-type" word-prop enum-c-type? ;

24
basis/alien/libraries/finder/finder-docs.factor Normal file
View File

@ -0,0 +1,24 @@
USING: help.markup help.syntax ;
IN: alien.libraries.finder
HELP: find-library*
{ $values
{ "name" "a shared library name" }
{ "path/f" "a filesystem path or f" }
}
{ $description
"Returns a filesystem path for a plain shared library name, or f if no library can be found."
} ;
HELP: find-library
{ $values
{ "name" "a shared library name" }
{ "path/library-not-found" "a filesystem path or " { $snippet "name" } }
}
{ $description
"Used to load libraries whose exact filenames is not known in advance:"
{ $code
"<< \"sqlite\" \"sqlite3\" find-library cdecl add-library >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "."
} ;

5
basis/alien/libraries/finder/finder-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: alien alien.libraries.finder tools.test ;
IN: alien.libraries.finder
{ f } [ "dont-exist" find-library* ] unit-test
{ "dont-exist" } [ "dont-exist" find-library ] unit-test

21
basis/alien/libraries/finder/finder.factor Normal file
View File

@ -0,0 +1,21 @@
USING: combinators kernel sequences system vocabs
alien.libraries ;
IN: alien.libraries.finder
HOOK: find-library* os ( name -- path/f )
: find-library ( name -- path/library-not-found )
dup find-library* [ nip ] when* ;
! Try to find the library from a list, but if it's not found,
! try to open a library that is the first name in that list anyway
! or "library_not_found" as a last resort for better debugging.
: find-library-from-list ( seq -- path/f )
dup [ find-library* ] map-find drop
[ nip ] [ ?first "library_not_found" or ] if* ;
{
{ [ os macosx? ] [ "alien.libraries.finder.macosx" ] }
{ [ os linux? ] [ "alien.libraries.finder.linux" ] }
{ [ os windows? ] [ "alien.libraries.finder.windows" ] }
} cond require

5
basis/alien/libraries/finder/linux/linux-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: alien.libraries.finder sequences tools.test ;
IN: alien.libraries.fidner.linux
{ t } [ "libm.so" "m" find-library subseq? ] unit-test
{ t } [ "libc.so" "c" find-library subseq? ] unit-test

52
basis/alien/libraries/finder/linux/linux.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2013 Björn Lindqvist, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license
USING: alien.libraries.finder arrays assocs
combinators.short-circuit io io.encodings.utf8 io.files
io.files.info io.launcher kernel sequences sets splitting system
unicode.categories ;
IN: alien.libraries.finder.linux
<PRIVATE
CONSTANT: mach-map {
{ ppc.64 { "libc6" "64bit" } }
{ x86.32 { "libc6" "x32" } }
{ x86.64 { "libc6" "x86-64" } }
}
: parse-ldconfig-lines ( string -- triple )
[
"=>" split1 [ [ blank? ] trim ] bi@
[
" " split1 [ "()" in? ] trim "," split
[ [ blank? ] trim ] map
[ "OS ABI:" head? not ] filter
] dip 3array
] map ;
: load-ldconfig-cache ( -- seq )
"/sbin/ldconfig -p" utf8 [ lines ] with-process-reader
rest parse-ldconfig-lines ;
: ldconfig-arch ( -- str )
mach-map cpu of { "libc6" } or ;
: name-matches? ( lib triple -- ? )
first swap ?head [ ?first CHAR: . = ] [ drop f ] if ;
: arch-matches? ( lib triple -- ? )
[ drop ldconfig-arch ] [ second swap subset? ] bi* ;
: ldconfig-matches? ( lib triple -- ? )
{ [ name-matches? ] [ arch-matches? ] } 2&& ;
: ldconfig-find-soname ( lib -- seq )
load-ldconfig-cache [ ldconfig-matches? ] with filter
[ third ] map ;
PRIVATE>
M: linux find-library*
"lib" prepend ldconfig-find-soname [
{ [ exists? ] [ file-info regular-file? ] } 1&&
] map-find nip ;

0
basis/tools/ps/platforms.txt → basis/alien/libraries/finder/linux/platforms.txt
View File

50
basis/alien/libraries/finder/macosx/macosx-tests.factor Normal file
View File

@ -0,0 +1,50 @@
USING: alien.libraries.finder
alien.libraries.finder.macosx.private sequences tools.test ;
IN: alien.libraries.finder.macosx
{
{
f
f
f
f
T{ framework-info f "Location" "Name.framework/Name" "Name" f f }
T{ framework-info f "Location" "Name.framework/Name_suffix" "Name" f "suffix" }
f
f
T{ framework-info f "Location" "Name.framework/Versions/A/Name" "Name" "A" f }
T{ framework-info f "Location" "Name.framework/Versions/A/Name_suffix" "Name" "A" "suffix" }
}
} [
{
"broken/path"
"broken/path/_suffix"
"Location/Name.framework"
"Location/Name.framework/_suffix"
"Location/Name.framework/Name"
"Location/Name.framework/Name_suffix"
"Location/Name.framework/Versions"
"Location/Name.framework/Versions/A"
"Location/Name.framework/Versions/A/Name"
"Location/Name.framework/Versions/A/Name_suffix"
} [ make-framework-info ] map
] unit-test
{
{
"/usr/lib/libSystem.dylib"
"/System/Library/Frameworks/System.framework/System"
}
} [
{
"libSystem.dylib"
"System.framework/System"
} [ dyld-find ] map
] unit-test
{ t } [ "libm.dylib" "m" find-library subseq? ] unit-test
{ t } [ "libc.dylib" "c" find-library subseq? ] unit-test
{ t } [ "libbz2.dylib" "bz2" find-library subseq? ] unit-test
{ t } [ "AGL.framework" "AGL" find-library subseq? ] unit-test

135
basis/alien/libraries/finder/macosx/macosx.factor Normal file
View File

@ -0,0 +1,135 @@
! Copyright (C) 2013 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors alien.libraries.finder arrays assocs
combinators.short-circuit environment io.files io.files.info
io.pathnames kernel locals make namespaces sequences splitting
system ;
IN: alien.libraries.finder.macosx
<PRIVATE
TUPLE: framework-info location name shortname version suffix ;
: make-framework-info ( filename -- info/f )
[ framework-info new ] dip
"/" split dup [ ".framework" tail? ] find drop [
cut [
[ "/" join ] bi@ [ >>location ] [ >>name ] bi*
] keep [
rest dup ?first "Versions" = [
rest dup empty? [
unclip swap [ >>version ] dip
] unless
] when ?first "_" split1 [ >>shortname ] [ >>suffix ] bi*
] unless-empty
] [ drop ] if* dup shortname>> empty? [ drop f ] when ;
CONSTANT: default-framework-fallback {
"~/Library/Frameworks"
"/Library/Frameworks"
"/Network/Library/Frameworks"
"/System/Library/Frameworks"
}
CONSTANT: default-library-fallback {
"~/lib"
"/usr/local/lib"
"/lib"
"/usr/lib"
}
SYMBOL: dyld-environment
: dyld-env ( name -- seq )
dyld-environment get [ at ] [ os-env ] if* ;
: dyld-paths ( name -- seq )
dyld-env [ ":" split ] [ f ] if* ;
: paths% ( name seq -- )
[ prepend-path , ] with each ;
: dyld-override-search ( name -- seq )
[
dup make-framework-info [
name>> "DYLD_FRAMEWORK_PATH" dyld-paths paths%
] when*
file-name "DYLD_LIBRARY_PATH" dyld-paths paths%
] { } make ;
SYMBOL: dyld-executable-path
: dyld-executable-path-search ( name -- seq )
"@executable_path/" ?head dyld-executable-path get and [
dyld-executable-path get prepend-path
] [
drop f
] if ;
:: dyld-default-search ( name -- seq )
name make-framework-info :> framework
name file-name :> basename
"DYLD_FALLBACK_FRAMEWORK_PATH" dyld-paths :> fallback-framework-path
"DYLD_FALLBACK_LIBRARY_PATH" dyld-paths :> fallback-library-path
[
name ,
framework [
name>> fallback-framework-path paths%
] when*
basename fallback-library-path paths%
framework fallback-framework-path empty? and [
framework name>> default-framework-fallback paths%
] when
fallback-library-path empty? [
basename default-library-fallback paths%
] when
] { } make ;
: dyld-image-suffix-search ( seq -- str )
"DYLD_IMAGE_SUFFIX" dyld-env [
swap [
[
[
".dylib" ?tail [ prepend ] dip
[ ".dylib" append ] when ,
] [
,
] bi
] with each
] { } make
] when* ;
: dyld-search-paths ( name -- paths )
[ dyld-override-search ]
[ dyld-executable-path-search ]
[ dyld-default-search ] tri 3append
dyld-image-suffix-search ;
PRIVATE>
: dyld-find ( name -- path/f )
dyld-search-paths
[ { [ exists? ] [ file-info regular-file? ] } 1&& ] find
[ nip ] when* ;
: framework-find ( name -- path )
dup dyld-find [ nip ] [
".framework" over start [
dupd head
] [
[ ".framework" append ] keep
] if* file-name append-path dyld-find
] if* ;
M: macosx find-library*
[ "lib" ".dylib" surround ]
[ ".dylib" append ]
[ ".framework/" over 3append ] tri 3array
[ dyld-find ] map-find drop ;

1
basis/alien/libraries/finder/macosx/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/alien/libraries/finder/windows/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

34
basis/alien/libraries/finder/windows/windows.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2013 Björn Lindqvist, John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: alien.libraries.finder arrays combinators.short-circuit
environment io.backend io.files io.files.info io.pathnames kernel
sequences splitting system system-info.windows ;
IN: alien.libraries.finder.windows
<PRIVATE
: search-paths ( -- seq )
"resource:" normalize-path
system-directory
windows-directory 3array
"PATH" os-env [ ";" split ] [ f ] if* append ;
: candidate-paths ( name -- seq )
search-paths over ".dll" tail? [
[ prepend-path ] with map
] [
[
[ prepend-path ]
[ [ ".dll" append ] [ prepend-path ] bi* ] 2bi
2array
] with map concat
] if ;
PRIVATE>
M: windows find-library*
candidate-paths [
{ [ exists? ] [ file-info regular-file? ] } 1&&
] map-find nip ;

2
basis/alien/libraries/libraries-docs.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien alien.syntax assocs help.markup
help.syntax io.backend kernel namespaces strings ;
IN: alien.libraries
HELP: <library>
HELP: make-library
{ $values
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
{ "library" library } }

17
basis/alien/libraries/libraries.factor
View File

@ -17,16 +17,20 @@ SYMBOL: libraries
libraries [ H{ } clone ] initialize
TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ;
TUPLE: library { path string } dll dlerror { abi abi initial: cdecl } ;
C: <library> library
ERROR: no-library name ;
: lookup-library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
over dup
[ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if
\ library boa ;
: open-dll ( path -- dll dll-error/f )
[ dlopen dup dll-valid? [ f ] [ dlerror ] if ]
[ f f ] if* ;
: make-library ( path abi -- library )
[ dup open-dll ] dip <library> ;
: library-dll ( library -- dll )
dup [ dll>> ] when ;
@ -48,7 +52,8 @@ M: library dispose dll>> [ dispose ] when* ;
: add-library ( name path abi -- )
3dup add-library? [
[ 2drop remove-library ]
[ <library> swap libraries get set-at ] 3bi
[ [ nip ] dip make-library ]
[ 2drop libraries get set-at ] 3tri
] [ 3drop ] if ;
: library-abi ( library -- abi )

4
basis/alien/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser parser eval debugger kernel
continuations words ;
continuations debugger eval parser tools.test vocabs.parser
words ;
IN: alien.parser.tests
TYPEDEF: char char2

32
basis/ascii/ascii-docs.factor
View File

@ -1,44 +1,44 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax kernel strings ;
IN: ascii
HELP: blank?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ascii?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $values { "ch" "a character" } { "?" boolean } }
{ $description "Tests for whether a number is an ASCII character." } ;
HELP: ch>lower
@ -50,23 +50,23 @@ HELP: ch>upper
{ $description "Converts an ASCII character to upper case." } ;
HELP: >lower
{ $values { "str" "a string" } { "lower" "a string" } }
{ $values { "str" string } { "lower" string } }
{ $description "Converts an ASCII string to lower case." } ;
HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } }
{ $values { "str" string } { "upper" string } }
{ $description "Converts an ASCII string to upper case." } ;
HELP: >title
{ $values { "str" "a string" } { "title" "a string" } }
{ $values { "str" string } { "title" string } }
{ $description "Converts a string to title case." } ;
HELP: >words
{ $values { "str" "a string" } { "words" "an array of slices" } }
{ $values { "str" string } { "words" "an array of slices" } }
{ $description "Divides the string up into words." } ;
HELP: capitalize
{ $values { "str" "a string" } { "str'" "a string" } }
{ $values { "str" string } { "str'" string } }
{ $description "Capitalize all the words in a string." } ;
ARTICLE: "ascii" "ASCII"

3
basis/atk/ffi/ffi.factor
View File

@ -13,7 +13,8 @@ LIBRARY: atk
<<
"atk" {
{ [ os windows? ] [ "libatk-1.0-0.dll" cdecl add-library ] }
{ [ os unix? ] [ drop ] }
{ [ os macosx? ] [ "libatk-1.0.dylib" cdecl add-library ] }
{ [ os unix? ] [ "libatk-1.0.so" cdecl add-library ] }
} cond
>>

19
basis/base64/base64.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators fry io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
io.streams.byte-array kernel math namespaces sbufs
sequences strings ;
IN: base64
@ -11,12 +11,15 @@ ERROR: malformed-base64 ;
: read1-ignoring ( ignoring stream -- ch )
dup stream-read1 pick dupd member?
[ drop read1-ignoring ] [ 2nip ] if ;
[ drop read1-ignoring ] [ 2nip ] if ; inline recursive
: read-ignoring ( n ignoring stream -- str )
'[ _ _ read1-ignoring ] replicate
[ { f 0 } member-eq? not ] "" filter-as
[ f ] when-empty ;
: push-ignoring ( accum ch -- accum )
dup { f 0 } member-eq? [ drop ] [ over push ] if ; inline
: read-ignoring ( n ignoring stream -- str/f )
[ [ <sbuf> ] keep ] 2dip
'[ _ _ read1-ignoring push-ignoring ] times
[ f ] [ "" like ] if-empty ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
@ -47,8 +50,8 @@ SYMBOL: column
: encode3 ( seq -- )
column output-stream get '[
swap be> { 3 2 1 0 } [
-6 * shift 0x3f bitand ch>base64 _ write1-lines
swap be> { -18 -12 -6 0 } [
shift 0x3f bitand ch>base64 _ write1-lines
] with each
] change ; inline

6
basis/binary-search/binary-search-docs.factor
View File

@ -2,7 +2,7 @@ IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $values { "seq" "a sorted sequence" } { "quot" { $quotation ( elt -- <=> ) } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
$nl
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
@ -34,13 +34,13 @@ HELP: sorted-index
{ index index-from last-index last-index-from sorted-index } related-words
HELP: sorted-member?
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" boolean } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
{ member? sorted-member? } related-words
HELP: sorted-member-eq?
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" boolean } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
{ member-eq? sorted-member-eq? } related-words

5
basis/bit-arrays/bit-arrays-docs.factor
View File

@ -1,5 +1,4 @@
USING: arrays help.markup help.syntax kernel
kernel.private math prettyprint strings vectors sbufs ;
USING: help.markup help.syntax math sequences ;
IN: bit-arrays
ARTICLE: "bit-arrays" "Bit arrays"
@ -48,7 +47,7 @@ HELP: <bit-array>
{ $description "Creates a new bit array with the given length and all elements initially set to " { $link f } "." } ;
HELP: >bit-array
{ $values { "seq" "a sequence" } { "bit-array" bit-array } }
{ $values { "seq" sequence } { "bit-array" bit-array } }
{ $description "Outputs a freshly-allocated bit array whose elements have the same boolean values as a given sequence." } ;
HELP: clear-bits

20
basis/bit-sets/bit-sets.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math
math.bitwise hints sets ;
USING: accessors bit-arrays fry kernel math math.bitwise
sequences sequences.private sets ;
IN: bit-sets
TUPLE: bit-set { table bit-array read-only } ;
@ -22,9 +22,7 @@ M: bit-set adjoin
M: bit-set delete
! This isn't allowed to throw an error if the elt wasn't
! in the set
over integer? [
[ f ] 2dip table>> ?set-nth
] [ 2drop ] if ;
over integer? [ [ f ] 2dip table>> ?set-nth ] [ 2drop ] if ;
! If you do binary set operations with a bit-set, it's expected
! that the other thing can also be represented as a bit-set
@ -37,13 +35,9 @@ ERROR: check-bit-set-failed ;
dup bit-set? [ check-bit-set-failed ] unless ; inline
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
[
[ [ length ] bi@ assert= ]
[ [ underlying>> ] bi@ ] 2bi
] dip 2map
] 3bi bit-array boa ; inline
[ drop [ length ] bi@ [ assert= ] keep ]
[ [ [ underlying>> ] bi@ ] dip 2map ] 3bi
bit-array boa ; inline
: (bit-set-op) ( set1 set2 -- table1 table2 )
[ set-like ] keep [ table>> ] bi@ ; inline
@ -66,7 +60,7 @@ M: bit-set subset?
[ intersect ] keep = ;
M: bit-set members
[ table>> length iota ] keep [ in? ] curry filter ;
table>> [ length iota ] keep '[ _ nth-unsafe ] filter ;
<PRIVATE

5
basis/bit-vectors/bit-vectors-docs.factor
View File

@ -1,5 +1,4 @@
USING: arrays bit-arrays help.markup help.syntax kernel
combinators ;
USING: help.markup help.syntax sequences ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
@ -30,7 +29,7 @@ HELP: <bit-vector>
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector
{ $values { "seq" "a sequence" } { "vector" bit-vector } }
{ $values { "seq" sequence } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{

2
basis/boxes/boxes-docs.factor
View File

@ -19,7 +19,7 @@ HELP: box>
{ $errors "Throws an error if the box is empty." } ;
HELP: ?box
{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } }
{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } }
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
ARTICLE: "boxes" "Boxes"

8
basis/cache/cache.factor vendored
View File

@ -38,9 +38,9 @@ M: cache-assoc dispose* clear-assoc ;
PRIVATE>
: purge-cache ( cache -- )
[ assoc>> ] [ max-age>> ] bi '[
[
[ assoc>> ] [ max-age>> ] bi V{ } clone [
'[
nip dup age>> 1 + [ >>age ] keep
_ < [ drop t ] [ dispose, f ] if
_ < [ drop t ] [ _ dispose-to f ] if
] assoc-filter! drop
] { } make [ last rethrow ] unless-empty ;
] keep [ last rethrow ] unless-empty ;

8
basis/cairo/ffi/ffi.factor
View File

@ -8,10 +8,10 @@ IN: cairo.ffi
! Adapted from cairo.h, version 1.8.10
<< {
{ [ os windows? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
{ [ os macosx? ] [ "cairo" "libcairo.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
<< "cairo" {
{ [ os windows? ] [ "libcairo-2.dll" cdecl add-library ] }
{ [ os macosx? ] [ "libcairo.dylib" cdecl add-library ] }
{ [ os unix? ] [ "libcairo.so" cdecl add-library ] }
} cond >>
LIBRARY: cairo

4
basis/calendar/calendar-docs.factor
View File

@ -175,7 +175,7 @@ HELP: nanoseconds
{ years months days hours minutes seconds milliseconds microseconds nanoseconds } related-words
HELP: leap-year?
{ $values { "obj" object } { "?" "a boolean" } }
{ $values { "obj" object } { "?" boolean } }
{ $description "Returns " { $link t } " if the object represents a leap year." }
{ $examples
{ $example "USING: calendar prettyprint ;"
@ -357,7 +357,7 @@ HELP: <zero>
{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
HELP: valid-timestamp?
{ $values { "timestamp" timestamp } { "?" "a boolean" } }
{ $values { "timestamp" timestamp } { "?" boolean } }
{ $description "Tests if a timestamp is valid or not." } ;
HELP: unix-1970

6
basis/calendar/calendar.factor
View File

@ -33,6 +33,8 @@ TUPLE: timestamp
C: <timestamp> timestamp
M: timestamp clone (clone) [ clone ] change-gmt-offset ;
: gmt-offset-duration ( -- duration )
0 0 0 gmt-offset <duration> ; inline
@ -324,10 +326,10 @@ GENERIC: time- ( time1 time2 -- time3 )
] if ;
: >local-time ( timestamp -- timestamp' )
gmt-offset-duration convert-timezone ;
clone gmt-offset-duration convert-timezone ;
: >gmt ( timestamp -- timestamp' )
dup gmt-offset>> dup instant =
clone dup gmt-offset>> dup instant =
[ drop ] [
[ neg +second 0 ] change-second
[ neg +minute 0 ] change-minute

205
basis/calendar/format/format-tests.factor
View File

@ -1,85 +1,120 @@
USING: calendar.format calendar kernel math tools.test
io.streams.string accessors io math.order sequences ;
IN: calendar.format.tests
[ 0 ] [
"Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ 1 ] [
"+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ -1 ] [
"-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ -1-1/2 ] [
"-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ 1+1/2 ] [
"+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 drop ] unit-test
[ 8/1000 -4 ] [
"2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
[ second>> ] [ gmt-offset>> hour>> ] bi
] unit-test
[ T{ duration f 0 0 0 0 0 0 } ] [
"GMT" parse-rfc822-gmt-offset
] unit-test
[ T{ duration f 0 0 0 -5 0 0 } ] [
"-0500" parse-rfc822-gmt-offset
] unit-test
[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
"Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
] unit-test
[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test
[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test
[ "Sun, 4 May 2008 07:00:00" ] [
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>string
] unit-test
[ "20080504070000" ] [
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>mdtm
] unit-test
[
T{ timestamp f
2008
5
26
0
37
42+2469/20000
T{ duration f 0 0 0 -5 0 0 }
}
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
[
T{ timestamp
{ year 2008 }
{ month 10 }
{ day 2 }
{ hour 23 }
{ minute 59 }
{ second 59 }
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }
}
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test
[ ]
[ { 2008 2009 } [ year. ] each ] unit-test
USING: calendar.format calendar kernel math tools.test
io.streams.string accessors io math.order sequences ;
IN: calendar.format.tests
[ 0 ] [
"Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ 1 ] [
"+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ -1 ] [
"-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ -1-1/2 ] [
"-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ 1+1/2 ] [
"+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours
] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 drop ] unit-test
[ 8/1000 -4 ] [
"2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
[ second>> ] [ gmt-offset>> hour>> ] bi
] unit-test
[ T{ duration f 0 0 0 0 0 0 } ] [
"GMT" parse-rfc822-gmt-offset
] unit-test
[ T{ duration f 0 0 0 -5 0 0 } ] [
"-0500" parse-rfc822-gmt-offset
] unit-test
[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
"Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
] unit-test
[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test
[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test
[ "Sun, 4 May 2008 07:00:00" ] [
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>string
] unit-test
[ "20080504070000" ] [
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>mdtm
] unit-test
[
T{ timestamp f
2008
5
26
0
37
42+2469/20000
T{ duration f 0 0 0 -5 0 0 }
}
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
[
T{ timestamp
{ year 2008 }
{ month 10 }
{ day 2 }
{ hour 23 }
{ minute 59 }
{ second 59 }
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }
}
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test
[ ]
[ { 2008 2009 } [ year. ] each ] unit-test
[
T{ timestamp
{ year 2013 }
{ month 4 }
{ day 23 }
{ hour 13 }
{ minute 50 }
{ second 24 }
}
] [ "2013-04-23T13:50:24" rfc3339>timestamp ] unit-test
{ "2001-12-14T21:59:43.100000-05:00" } [ "2001-12-14T21:59:43.1-05:00" rfc3339>timestamp timestamp>rfc3339 ] unit-test
[
T{ timestamp
{ year 2001 }
{ month 12 }
{ day 15 }
{ hour 02 }
{ minute 59 }
{ second 43+1/10 }
}
] [ "2001-12-15 02:59:43.1Z" rfc3339>timestamp ] unit-test
[
T{ timestamp
{ year 2001 }
{ month 12 }
{ day 15 }
{ hour 02 }
{ minute 59 }
{ second 43+1/10 }
}
] [ "2001-12-15 02:59:43.1Z" rfc3339>timestamp ] unit-test

666
basis/calendar/format/format.factor
View File

@ -1,328 +1,338 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar calendar.format.macros
combinators io io.streams.string kernel math math.functions
math.order math.parser present sequences typed ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
: write-00 ( n -- ) pad-00 write ;
: write-0000 ( n -- ) pad-0000 write ;
: write-00000 ( n -- ) pad-00000 write ;
: hh ( time -- ) hour>> write-00 ;
: mm ( time -- ) minute>> write-00 ;
: ss ( time -- ) second>> >integer write-00 ;
: D ( time -- ) day>> number>string write ;
: DD ( time -- ) day>> write-00 ;
: DAY ( time -- ) day-of-week day-abbreviation3 write ;
: MM ( time -- ) month>> write-00 ;
: MONTH ( time -- ) month>> month-abbreviation write ;
: YYYY ( time -- ) year>> write-0000 ;
: YYYYY ( time -- ) year>> write-00000 ;
: expect ( str -- )
read1 swap member? [ "Parse error" throw ] unless ;
: read-00 ( -- n ) 2 read string>number ;
: read-000 ( -- n ) 3 read string>number ;
: read-0000 ( -- n ) 4 read string>number ;
: hhmm>timestamp ( hhmm -- timestamp )
[
0 0 0 read-00 read-00 0 instant <timestamp>
] with-string-reader ;
GENERIC: day. ( obj -- )
M: integer day. ( n -- )
number>string dup length 2 < [ bl ] when write ;
M: timestamp day. ( timestamp -- )
day>> day. ;
GENERIC: month. ( obj -- )
M: array month. ( pair -- )
first2
[ month-name write bl number>string print ]
[ 1 zeller-congruence ]
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> "" concat-as write
[
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each-integer nl ;
M: timestamp month. ( timestamp -- )
[ year>> ] [ month>> ] bi 2array month. ;
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1 + 2array month. nl ] with each-integer ;
M: timestamp year. ( timestamp -- )
year>> year. ;
: timestamp>mdtm ( timestamp -- str )
[ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
: (timestamp>string) ( timestamp -- )
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
: timestamp>string ( timestamp -- str )
[ (timestamp>string) ] with-string-writer ;
: (write-gmt-offset) ( duration -- )
[ hh ] [ mm ] bi ;
: write-gmt-offset ( gmt-offset -- )
dup instant <=> {
{ +eq+ [ drop "GMT" write ] }
{ +lt+ [ "-" write before (write-gmt-offset) ] }
{ +gt+ [ "+" write (write-gmt-offset) ] }
} case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
[
[ (timestamp>string) bl ]
[ gmt-offset>> write-gmt-offset ]
bi
] with-string-writer ;
: timestamp>http-string ( timestamp -- str )
#! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
>gmt timestamp>rfc822 ;
: (timestamp>cookie-string) ( timestamp -- )
>gmt
{ DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
: timestamp>cookie-string ( timestamp -- str )
[ (timestamp>cookie-string) ] with-string-writer ;
: (write-rfc3339-gmt-offset) ( duration -- )
[ hh ":" write ] [ mm ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
dup instant <=> {
{ +eq+ [ drop "Z" write ] }
{ +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
{ +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
} case ;
: (timestamp>rfc3339) ( timestamp -- )
{
YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
[ gmt-offset>> write-rfc3339-gmt-offset ]
} formatted ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
: signed-gmt-offset ( dt ch -- dt' )
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
: read-rfc3339-gmt-offset ( ch -- dt )
dup CHAR: Z = [ drop instant ] [
[
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
] dip signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
read-0000 "-" expect read-00 "-" expect read-00 ;
: read-hms ( -- h m s )
read-00 ":" expect read-00 ":" expect read-00 ;
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until [
[ string>number ] [ length 10^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
read-ymd
"Tt" expect
read-hms
read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
read-rfc3339-gmt-offset
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
ERROR: invalid-timestamp-format ;
: check-timestamp ( obj/f -- obj )
[ invalid-timestamp-format ] unless* ;
: read-token ( seps -- token )
[ read-until ] keep member? check-timestamp drop ;
: read-sp ( -- token ) " " read-token ;
: checked-number ( str -- n )
string>number check-timestamp ;
: parse-rfc822-gmt-offset ( string -- dt )
dup "GMT" = [ drop instant ] [
unclip [
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
] dip signed-gmt-offset
] if ;
: (rfc822>timestamp) ( -- timestamp )
timestamp new
"," read-token day-abbreviations3 member? check-timestamp drop
read1 CHAR: \s assert=
read-sp checked-number >>day
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
readln parse-rfc822-gmt-offset >>gmt-offset ;
: rfc822>timestamp ( str -- timestamp )
[ (rfc822>timestamp) ] with-string-reader ;
: check-day-name ( str -- )
[ day-abbreviations3 member? ] [ day-names member? ] bi or
check-timestamp drop ;
: (cookie-string>timestamp-1) ( -- timestamp )
timestamp new
"," read-token check-day-name
read1 CHAR: \s assert=
"-" read-token checked-number >>day
"-" read-token month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
readln parse-rfc822-gmt-offset >>gmt-offset ;
: cookie-string>timestamp-1 ( str -- timestamp )
[ (cookie-string>timestamp-1) ] with-string-reader ;
: (cookie-string>timestamp-2) ( -- timestamp )
timestamp new
read-sp check-day-name
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>day
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
read-sp checked-number >>year
readln parse-rfc822-gmt-offset >>gmt-offset ;
: cookie-string>timestamp-2 ( str -- timestamp )
[ (cookie-string>timestamp-2) ] with-string-reader ;
: cookie-string>timestamp ( str -- timestamp )
{
[ cookie-string>timestamp-1 ]
[ cookie-string>timestamp-2 ]
[ rfc822>timestamp ]
} attempt-all-quots ;
: (ymdhms>timestamp) ( -- timestamp )
read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
0 0 0 read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
read-ymd <date-gmt> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
: (timestamp>ymd) ( timestamp -- )
{ YYYY "-" MM "-" DD } formatted ;
TYPED: timestamp>ymd ( timestamp: timestamp -- str )
[ (timestamp>ymd) ] with-string-writer ;
: (timestamp>hms) ( timestamp -- )
{ hh ":" mm ":" ss } formatted ;
TYPED: timestamp>hms ( timestamp: timestamp -- str )
[ (timestamp>hms) ] with-string-writer ;
: (timestamp>hm) ( timestamp -- )
{ hh ":" mm } formatted ;
TYPED: timestamp>hm ( timestamp: timestamp -- str )
[ (timestamp>hm) ] with-string-writer ;
TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
[
>gmt
{ (timestamp>ymd) " " (timestamp>hms) } formatted
] with-string-writer ;
: file-time-string ( timestamp -- string )
[
{
MONTH " " DD " "
[
dup now [ year>> ] same?
[ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
]
} formatted
] with-string-writer ;
M: timestamp present timestamp>string ;
TYPED: duration>hm ( duration: duration -- string )
[ duration>hours >integer 24 mod pad-00 ]
[ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
TYPED: duration>human-readable ( duration: duration -- string )
[
[
duration>years >integer
[
[ number>string write ]
[ 1 > " years, " " year, " ? write ] bi
] unless-zero
] [
duration>days >integer 365 mod
[
[ number>string write ]
[ 1 > " days, " " day, " ? write ] bi
] unless-zero
] [ duration>hm write ] tri
] with-string-writer ;
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar calendar.format.macros
combinators io io.streams.string kernel math math.functions
math.order math.parser math.parser.private present sequences
typed ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
: write-00 ( n -- ) pad-00 write ;
: write-0000 ( n -- ) pad-0000 write ;
: write-00000 ( n -- ) pad-00000 write ;
: hh ( time -- ) hour>> write-00 ;
: mm ( time -- ) minute>> write-00 ;
: ss ( time -- ) second>> >integer write-00 ;
: D ( time -- ) day>> number>string write ;
: DD ( time -- ) day>> write-00 ;
: DAY ( time -- ) day-of-week day-abbreviation3 write ;
: MM ( time -- ) month>> write-00 ;
: MONTH ( time -- ) month>> month-abbreviation write ;
: YYYY ( time -- ) year>> write-0000 ;
: YYYYY ( time -- ) year>> write-00000 ;
: expect ( str -- )
read1 swap member? [ "Parse error" throw ] unless ;
: read-00 ( -- n ) 2 read string>number ;
: read-000 ( -- n ) 3 read string>number ;
: read-0000 ( -- n ) 4 read string>number ;
: hhmm>timestamp ( hhmm -- timestamp )
[
0 0 0 read-00 read-00 0 instant <timestamp>
] with-string-reader ;
GENERIC: day. ( obj -- )
M: integer day. ( n -- )
number>string dup length 2 < [ bl ] when write ;
M: timestamp day. ( timestamp -- )
day>> day. ;
GENERIC: month. ( obj -- )
M: array month. ( pair -- )
first2
[ month-name write bl number>string print ]
[ 1 zeller-congruence ]
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
over " " <repetition> "" concat-as write
[
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each-integer nl ;
M: timestamp month. ( timestamp -- )
[ year>> ] [ month>> ] bi 2array month. ;
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1 + 2array month. nl ] with each-integer ;
M: timestamp year. ( timestamp -- )
year>> year. ;
: timestamp>mdtm ( timestamp -- str )
[ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
: (timestamp>string) ( timestamp -- )
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
: timestamp>string ( timestamp -- str )
[ (timestamp>string) ] with-string-writer ;
: (write-gmt-offset) ( duration -- )
[ hh ] [ mm ] bi ;
: write-gmt-offset ( gmt-offset -- )
dup instant <=> {
{ +eq+ [ drop "GMT" write ] }
{ +lt+ [ "-" write before (write-gmt-offset) ] }
{ +gt+ [ "+" write (write-gmt-offset) ] }
} case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
[
[ (timestamp>string) bl ]
[ gmt-offset>> write-gmt-offset ]
bi
] with-string-writer ;
: timestamp>http-string ( timestamp -- str )
#! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
>gmt timestamp>rfc822 ;
: (timestamp>cookie-string) ( timestamp -- )
>gmt
{ DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
: timestamp>cookie-string ( timestamp -- str )
[ (timestamp>cookie-string) ] with-string-writer ;
: (write-rfc3339-gmt-offset) ( duration -- )
[ hh ":" write ] [ mm ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
dup instant <=> {
{ +eq+ [ drop "Z" write ] }
{ +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
{ +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
} case ;
! Should be enough for anyone, allows to not do a fancy
! algorithm to detect infinite decimals (e.g 1/3)
: ss.SSSSSS ( timestamp -- )
second>> >float "%.6f" format-float 9 CHAR: 0 pad-head write ;
: (timestamp>rfc3339) ( timestamp -- )
{
YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
[ gmt-offset>> write-rfc3339-gmt-offset ]
} formatted ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
: signed-gmt-offset ( dt ch -- dt' )
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
: read-rfc3339-gmt-offset ( ch -- dt )
{
{ f [ instant ] }
{ CHAR: Z [ instant ] }
[
[
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
] dip signed-gmt-offset
]
} case ;
: read-ymd ( -- y m d )
read-0000 "-" expect read-00 "-" expect read-00 ;
: read-hms ( -- h m s )
read-00 ":" expect read-00 ":" expect read-00 ;
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until [
[ string>number ] [ length 10^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
read-ymd
"Tt \t" expect
read-hms
read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
read-rfc3339-gmt-offset
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
ERROR: invalid-timestamp-format ;
: check-timestamp ( obj/f -- obj )
[ invalid-timestamp-format ] unless* ;
: read-token ( seps -- token )
[ read-until ] keep member? check-timestamp drop ;
: read-sp ( -- token ) " " read-token ;
: checked-number ( str -- n )
string>number check-timestamp ;
: parse-rfc822-gmt-offset ( string -- dt )
dup "GMT" = [ drop instant ] [
unclip [
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
] dip signed-gmt-offset
] if ;
: (rfc822>timestamp) ( -- timestamp )
timestamp new
"," read-token day-abbreviations3 member? check-timestamp drop
read1 CHAR: \s assert=
read-sp checked-number >>day
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
readln parse-rfc822-gmt-offset >>gmt-offset ;
: rfc822>timestamp ( str -- timestamp )
[ (rfc822>timestamp) ] with-string-reader ;
: check-day-name ( str -- )
[ day-abbreviations3 member? ] [ day-names member? ] bi or
check-timestamp drop ;
: (cookie-string>timestamp-1) ( -- timestamp )
timestamp new
"," read-token check-day-name
read1 CHAR: \s assert=
"-" read-token checked-number >>day
"-" read-token month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>year
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
readln parse-rfc822-gmt-offset >>gmt-offset ;
: cookie-string>timestamp-1 ( str -- timestamp )
[ (cookie-string>timestamp-1) ] with-string-reader ;
: (cookie-string>timestamp-2) ( -- timestamp )
timestamp new
read-sp check-day-name
read-sp month-abbreviations index 1 + check-timestamp >>month
read-sp checked-number >>day
":" read-token checked-number >>hour
":" read-token checked-number >>minute
read-sp checked-number >>second
read-sp checked-number >>year
readln parse-rfc822-gmt-offset >>gmt-offset ;
: cookie-string>timestamp-2 ( str -- timestamp )
[ (cookie-string>timestamp-2) ] with-string-reader ;
: cookie-string>timestamp ( str -- timestamp )
{
[ cookie-string>timestamp-1 ]
[ cookie-string>timestamp-2 ]
[ rfc822>timestamp ]
} attempt-all-quots ;
: (ymdhms>timestamp) ( -- timestamp )
read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
0 0 0 read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
read-ymd <date-gmt> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
: (timestamp>ymd) ( timestamp -- )
{ YYYY "-" MM "-" DD } formatted ;
TYPED: timestamp>ymd ( timestamp: timestamp -- str )
[ (timestamp>ymd) ] with-string-writer ;
: (timestamp>hms) ( timestamp -- )
{ hh ":" mm ":" ss } formatted ;
TYPED: timestamp>hms ( timestamp: timestamp -- str )
[ (timestamp>hms) ] with-string-writer ;
: (timestamp>hm) ( timestamp -- )
{ hh ":" mm } formatted ;
TYPED: timestamp>hm ( timestamp: timestamp -- str )
[ (timestamp>hm) ] with-string-writer ;
TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
[
>gmt
{ (timestamp>ymd) " " (timestamp>hms) } formatted
] with-string-writer ;
: file-time-string ( timestamp -- string )
[
{
MONTH " " DD " "
[
dup now [ year>> ] same?
[ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
]
} formatted
] with-string-writer ;
M: timestamp present timestamp>string ;
TYPED: duration>hm ( duration: duration -- string )
[ duration>hours >integer 24 mod pad-00 ]
[ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
TYPED: duration>human-readable ( duration: duration -- string )
[
[
duration>years >integer
[
[ number>string write ]
[ 1 > " years, " " year, " ? write ] bi
] unless-zero
] [
duration>days >integer 365 mod
[
[ number>string write ]
[ 1 > " days, " " day, " ? write ] bi
] unless-zero
] [ duration>hm write ] tri
] with-string-writer ;

7
basis/calendar/threads/threads.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar math system threads ;
USING: calendar threads ;
IN: calendar.threads
M: duration sleep
duration>nanoseconds >integer nano-count + sleep-until ;
M: duration sleep duration>nanoseconds sleep ;
M: timestamp sleep-until now time- sleep ;

4
basis/calendar/unix/unix.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.data calendar calendar.private
classes.struct kernel math system unix unix.time unix.types ;
classes.struct kernel math system libc unix unix.time unix.types ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
@ -35,7 +35,7 @@ M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ;
: current-timeval ( -- timeval )
timeval <struct> f [ gettimeofday io-error ] 2keep drop ; inline
timeval <struct> [ f gettimeofday io-error ] keep ; inline
: system-micros ( -- n )
current-timeval timeval>micros ;

14
basis/channels/channels-docs.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup ;
USING: help.syntax help.markup kernel ;
IN: channels
HELP: <channel>
{ $values { "channel" "a channel object" }
{ $values { "channel" channel }
}
{ $description "Create a channel that can be used for communicating between "
"concurrent processes and threads. " { $link to } " and " { $link from }
@ -15,19 +15,19 @@ HELP: <channel>
{ $see-also from to } ;
HELP: to
{ $values { "value" "an object" }
{ "channel" "a channel object" }
{ $values { "value" object }
{ "channel" channel }
}
{ $description "Sends an object to a channel. The send operation is synchronous."
" It will block the calling thread until there is a receiver waiting "
"for data on the channel. It will return when the receiver has received "
"the data successfully."
"the data successfully."
}
{ $see-also <channel> from } ;
HELP: from
{ $values { "channel" "a channel object" }
{ "value" "an object" }
{ $values { "channel" channel }
{ "value" object }
}
{ $description "Receives an object from a channel. The operation is synchronous."
" It will block the calling thread until there is data in the channel."

6
basis/channels/remote/remote-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: channels concurrency.distributed help.markup help.syntax
io.servers ;
io.servers strings ;
IN: channels.remote
HELP: <remote-channel>
@ -20,7 +20,7 @@ HELP: <remote-channel>
{ $see-also publish unpublish } ;
HELP: unpublish
{ $values { "id" "a string" }
{ $values { "id" string }
}
{ $description "Stop a previously published channel from being "
"accessible by remote nodes."
@ -32,7 +32,7 @@ HELP: unpublish
HELP: publish
{ $values { "channel" "a channel object" }
{ "id" "a string" }
{ "id" string }
}
{ $description "Make a channel accessible via remote Factor nodes. "
"An id is returned that can be used by another node to use "

1
basis/checksums/fletcher/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

17
basis/checksums/fletcher/fletcher-docs.factor Normal file
View File

@ -0,0 +1,17 @@
USING: help.markup help.syntax ;
IN: checksums.fletcher
HELP: fletcher-16
{ $class-description "Fletcher's 16-bit checksum algorithm." } ;
HELP: fletcher-32
{ $class-description "Fletcher's 32-bit checksum algorithm." } ;
HELP: fletcher-64
{ $class-description "Fletcher's 64-bit checksum algorithm." } ;
ARTICLE: "checksums.fletcher" "Fletcher's checksum"
"The Fletcher checksum is an algorithm for computing a position-dependent checksum devised by John G. Fletcher at Lawrence Livermore Labs in the late 1970s."
{ $subsections fletcher-16 fletcher-32 fletcher-64 } ;
ABOUT: "checksums.fletcher"

10
basis/checksums/fletcher/fletcher-tests.factor Normal file
View File

@ -0,0 +1,10 @@
USING: checksums kernel sequences tools.test ;
IN: checksums.fletcher
{
{ 51440 3948201259 14034561336514601929 }
} [
"abcde" { fletcher-16 fletcher-32 fletcher-64 }
[ checksum-bytes ] with map
] unit-test

27
basis/checksums/fletcher/fletcher.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2013 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: checksums grouping io.binary kernel locals math sequences
;
IN: checksums.fletcher
SINGLETON: fletcher-16
SINGLETON: fletcher-32
SINGLETON: fletcher-64
INSTANCE: fletcher-16 checksum
INSTANCE: fletcher-32 checksum
INSTANCE: fletcher-64 checksum
:: fletcher ( seq k -- n )
k 16 / :> chars
k 2 / 2^ :> base
base 1 - :> modulo
0 0 seq chars <groups> [
be> + modulo mod [ + modulo mod ] keep
] each [ base * ] [ + ] bi* ; inline
M: fletcher-16 checksum-bytes drop 16 fletcher ;
M: fletcher-32 checksum-bytes drop 32 fletcher ;
M: fletcher-64 checksum-bytes drop 64 fletcher ;

1
basis/checksums/fletcher/summary.txt Normal file
View File

@ -0,0 +1 @@
Fletcher's checksum algorithm

2
basis/checksums/internet/internet.factor
View File

@ -10,7 +10,7 @@ SINGLETON: internet ! RFC 1071
INSTANCE: internet checksum
M: internet checksum-bytes
drop 0 swap 2 <groups> [ le> + ] each
drop 2 <groups> [ le> ] map-sum
[ -16 shift ] [ 0xffff bitand ] bi +
[ -16 shift ] keep + bitnot 2 >le ;

68
basis/checksums/md5/md5.factor
View File

@ -1,11 +1,9 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data kernel io io.binary io.files
io.streams.byte-array math math.functions math.parser namespaces
splitting grouping strings sequences byte-arrays locals
sequences.private macros fry io.encodings.binary math.bitwise
checksums accessors checksums.common checksums.stream
combinators combinators.smart specialized-arrays literals hints ;
USING: accessors alien.c-types alien.data byte-arrays checksums
checksums.common checksums.stream combinators fry grouping hints
kernel kernel.private literals locals macros math math.bitwise
math.functions sequences sequences.private specialized-arrays ;
FROM: sequences.private => change-nth-unsafe ;
SPECIALIZED-ARRAY: uint
IN: checksums.md5
@ -14,7 +12,9 @@ SINGLETON: md5
INSTANCE: md5 stream-checksum
TUPLE: md5-state < checksum-state state old-state ;
TUPLE: md5-state < checksum-state
{ state uint-array }
{ old-state uint-array } ;
: <md5-state> ( -- md5 )
md5-state new-checksum-state
@ -26,16 +26,13 @@ M: md5 initialize-checksum-state drop <md5-state> ;
<PRIVATE
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
[ old-state<< ] [ state<< ] bi ;
[ state>> ] [ old-state>> [ w+ ] 2map dup clone ] [ ] tri
[ old-state<< ] [ state<< ] bi ; inline
CONSTANT: T
$[
80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
]
CONSTANT: T $[
80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
]
:: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
@ -84,14 +81,14 @@ CONSTANT: d 3
k x nth-unsafe w+
i T nth-unsafe w+
s bitroll-32
b state nth-unsafe w+ 32 bits
b state nth-unsafe w+
] change-nth-unsafe ; inline
MACRO: with-md5-round ( ops quot -- )
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
: (process-md5-block-F) ( block state -- )
{
{ uint-array uint-array } declare {
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
[ c d a b 2 S13 3 ]
@ -111,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- )
} [ F ] with-md5-round ;
: (process-md5-block-G) ( block state -- )
{
{ uint-array uint-array } declare {
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
[ c d a b 11 S23 19 ]
@ -131,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- )
} [ G ] with-md5-round ;
: (process-md5-block-H) ( block state -- )
{
{ uint-array uint-array } declare {
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
[ c d a b 11 S33 35 ]
@ -151,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- )
} [ H ] with-md5-round ;
: (process-md5-block-I) ( block state -- )
{
{ uint-array uint-array } declare {
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
[ c d a b 14 S43 51 ]
@ -170,11 +167,6 @@ MACRO: with-md5-round ( ops quot -- )
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ;
HINTS: (process-md5-block-F) { uint-array md5-state } ;
HINTS: (process-md5-block-G) { uint-array md5-state } ;
HINTS: (process-md5-block-H) { uint-array md5-state } ;
HINTS: (process-md5-block-I) { uint-array md5-state } ;
: byte-array>le ( byte-array -- byte-array )
little-endian? [
dup 4 <groups> [
@ -183,19 +175,11 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ;
] each
] unless ;
: uint-array-cast-le ( byte-array -- uint-array )
byte-array>le uint cast-array ;
HINTS: byte-array>le byte-array ;
HINTS: uint-array-cast-le byte-array ;
: uint-array>byte-array-le ( uint-array -- byte-array )
underlying>> byte-array>le ;
HINTS: uint-array>byte-array-le uint-array ;
M: md5-state checksum-block ( block state -- )
M: md5-state checksum-block
[
[ uint-array-cast-le ] [ state>> ] bi* {
[ byte-array>le uint cast-array ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
@ -205,18 +189,20 @@ M: md5-state checksum-block ( block state -- )
nip update-md5
] 2bi ;
: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
: md5>checksum ( md5 -- bytes )
state>> underlying>> byte-array>le ;
M: md5-state clone ( md5 -- new-md5 )
M: md5-state clone
call-next-method
[ clone ] change-state
[ clone ] change-old-state ;
M: md5-state get-checksum ( md5 -- bytes )
clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
M: md5-state get-checksum
clone
[ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
[ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
M: md5 checksum-stream ( stream checksum -- byte-array )
M: md5 checksum-stream
drop
[ <md5-state> ] dip add-checksum-stream get-checksum ;

1
basis/checksums/murmur/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

11
basis/checksums/murmur/murmur-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.murmur
HELP: murmur3-32
{ $class-description "MurmurHash3 32-bit checksum algorithm." } ;
ARTICLE: "checksums.murmur" "MurmurHash checksum"
"MurmurHash is a non-cryptographic hash function suitable for general hash-based lookup, created by Austin Appleby in 2008."
{ $subsections murmur3-32 } ;
ABOUT: "checksums.murmur"

38
basis/checksums/murmur/murmur-tests.factor Normal file
View File

@ -0,0 +1,38 @@
USING: byte-arrays checksums fry kernel math sequences
tools.test ;
IN: checksums.murmur
{ 455139366 } [ "asdf" >byte-array 0 <murmur3-32> checksum-bytes ] unit-test
{ 417250299 } [ "asdf" >byte-array 156 <murmur3-32> checksum-bytes ] unit-test
{ 3902511862 } [ "abcde" >byte-array 0 <murmur3-32> checksum-bytes ] unit-test
{ 2517562459 } [ "abcde" >byte-array 156 <murmur3-32> checksum-bytes ] unit-test
{ 2444432334 } [ "12345678" >byte-array 0 <murmur3-32> checksum-bytes ] unit-test
{ 2584512840 } [ "12345678" >byte-array 156 <murmur3-32> checksum-bytes ] unit-test
{ 3560398725 } [ "hello, world!!!" >byte-array 156 <murmur3-32> checksum-bytes ] unit-test
{
{
3903553677
3120384252
3928660296
2995164002
500661690
2764333444
1941147762
161439790
2584512840
3803370487
626154228
}
} [
"1234567890" [ length 1 + ] keep 156 <murmur3-32>
'[ _ swap head _ checksum-bytes ] { } map-integers
] unit-test
{ t } [
"1234567890" dup >byte-array [
[ length 1 + ] keep 156 <murmur3-32>
'[ _ swap head _ checksum-bytes ] { } map-integers
] bi@ =
] unit-test

53
basis/checksums/murmur/murmur.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2013 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data byte-arrays
checksums fry grouping io.binary kernel math math.bitwise
math.ranges sequences ;
IN: checksums.murmur
TUPLE: murmur3-32 seed ;
C: <murmur3-32> murmur3-32
CONSTANT: c1 0xcc9e2d51
CONSTANT: c2 0x1b873593
CONSTANT: r1 15
CONSTANT: r2 13
CONSTANT: m 5
CONSTANT: n 0xe6546b64
<PRIVATE
: (hash-chunk) ( k -- k' )
c1 w* r1 bitroll-32 c2 w* ; inline
: hash-chunk ( hash k -- hash' )
(hash-chunk) bitxor r2 bitroll-32 m w* n w+ ; inline
: main-loop ( seq hash -- seq hash' )
over byte-array? little-endian? and [
[ 0 over length 4 - 4 <range> ] dip
[ pick <displaced-alien> int deref hash-chunk ] reduce
] [
[ dup length 4 mod dupd head-slice* 4 <groups> ] dip
[ le> hash-chunk ] reduce
] if ; inline
: end-case ( seq hash -- hash' )
swap dup length
[ 4 mod tail-slice* be> (hash-chunk) bitxor ]
[ bitxor ] bi 32 bits ; inline
: avalanche ( hash -- hash' )
[ -16 shift ] [ bitxor 0x85ebca6b w* ] bi
[ -13 shift ] [ bitxor 0xc2b2ae35 w* ] bi
[ -16 shift ] [ bitxor ] bi ; inline
PRIVATE>
M: murmur3-32 checksum-bytes ( bytes checksum -- value )
seed>> 32 bits main-loop end-case avalanche ;
INSTANCE: murmur3-32 checksum

1
basis/checksums/murmur/summary.txt Normal file
View File

@ -0,0 +1 @@
MurmurHash checksum algorithm

45
basis/checksums/sha/sha.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
sequences.generalizations sequences.private splitting strings ;
USING: accessors arrays checksums checksums.common
checksums.stream combinators combinators.smart fry grouping
io.binary kernel literals locals math math.bitwise math.ranges
sequences sequences.generalizations sequences.private ;
IN: checksums.sha
SINGLETON: sha1
@ -16,10 +15,14 @@ SINGLETON: sha-256
INSTANCE: sha-224 stream-checksum
INSTANCE: sha-256 stream-checksum
TUPLE: sha1-state < checksum-state K H W word-size ;
TUPLE: sha1-state < checksum-state
{ K array }
{ H array }
{ W array }
{ word-size fixnum } ;
CONSTANT: initial-H-sha1
{
{
0x67452301
0xefcdab89
0x98badcfe
@ -36,7 +39,10 @@ CONSTANT: K-sha1
4 { } nappend-as
]
TUPLE: sha2-state < checksum-state K H word-size ;
TUPLE: sha2-state < checksum-state
{ K array }
{ H array }
{ word-size fixnum } ;
TUPLE: sha2-short < sha2-state ;
@ -308,21 +314,21 @@ M: sha2-short checksum-block
[ prepare-message-schedule ]
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: sequence>byte-array ( seq n -- string )
'[ _ >be ] map B{ } concat-as ;
: sequence>byte-array ( seq n -- bytes )
'[ _ >be ] map B{ } concat-as ; inline
: sha1>checksum ( sha2 -- bytes )
H>> 4 sequence>byte-array ;
H>> 4 sequence>byte-array ; inline
: sha-224>checksum ( sha2 -- bytes )
H>> 7 head 4 sequence>byte-array ;
H>> 7 head 4 sequence>byte-array ; inline
: sha-256>checksum ( sha2 -- bytes )
H>> 4 sequence>byte-array ;
H>> 4 sequence>byte-array ; inline
: pad-last-short-block ( state -- )
[ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
[ checksum-block ] curry each ;
[ checksum-block ] curry each ; inline
PRIVATE>
@ -349,7 +355,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
[ [ 14 - ] dip nth-unsafe bitxor ]
[ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ]
} 2cleave set-nth-unsafe ;
} 2cleave set-nth-unsafe ; inline
: prepare-sha1-message-schedule ( seq -- w-seq )
4 <groups> [ be> ] map
@ -363,7 +369,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
{ 1 [ bitxor bitxor ] }
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
{ 3 [ bitxor bitxor ] }
} case ;
} case ; inline
:: inner-loop ( n H W K -- temp )
a H nth-unsafe :> A
@ -374,16 +380,16 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
[
A 5 bitroll-32
B C D n sha1-f
B C D n sha1-f
E
n K nth-unsafe
n W nth-unsafe
] sum-outputs 32 bits ;
] sum-outputs 32 bits ; inline
:: process-sha1-chunk ( bytes H W K state -- )
:: process-sha1-chunk ( H W K state -- )
80 [
H W K inner-loop
d H nth-unsafe e H set-nth-unsafe
@ -397,7 +403,6 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
M:: sha1-state checksum-block ( bytes state -- )
bytes prepare-sha1-message-schedule state W<<
bytes
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
M: sha1-state get-checksum

1
basis/checksums/superfast/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

1
basis/checksums/superfast/summary.txt Normal file
View File

@ -0,0 +1 @@
SuperFastHash checksum algorithm

12
basis/checksums/superfast/superfast-docs.factor Normal file
View File

@ -0,0 +1,12 @@
USING: help.markup help.syntax ;
IN: checksums.superfast
HELP: superfast
{ $class-description "SuperFastHash checksum algorithm." } ;
ARTICLE: "checksums.superfast" "SuperFastHash checksum"
"SuperFastHash is a hash, created by Paul Hsieh. For more information see: "
{ $url "http://www.azillionmonkeys.com/qed/hash.html" }
{ $subsections superfast } ;
ABOUT: "checksums.superfast"

30
basis/checksums/superfast/superfast-tests.factor Normal file
View File

@ -0,0 +1,30 @@
USING: byte-arrays checksums fry kernel math sequences
tools.test ;
IN: checksums.superfast
{
{
0
4064760690
2484602674
1021960881
3514307704
762925594
95280079
516333699
1761749771
3841726064
2549850032
}
} [
"1234567890" [ length 1 + ] keep 0 <superfast>
'[ _ swap head _ checksum-bytes ] { } map-integers
] unit-test
{ t } [
"1234567890" dup >byte-array [
[ length 1 + ] keep 0 <superfast>
'[ _ swap head _ checksum-bytes ] { } map-integers
] bi@ =
] unit-test

57
basis/checksums/superfast/superfast.factor Normal file
View File

@ -0,0 +1,57 @@
! Copyright (C) 2013 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data byte-arrays
checksums combinators fry grouping io.binary kernel math
math.bitwise math.ranges sequences sequences.private ;
IN: checksums.superfast
TUPLE: superfast seed ;
C: <superfast> superfast
<PRIVATE
: (main-loop) ( hash n -- hash' )
[ 16 bits ] [ -16 shift ] bi
[ + ] [ 11 shift dupd bitxor ] bi*
[ 16 shift ] [ bitxor ] bi* 32 bits
[ -11 shift ] [ + ] bi ; inline
: main-loop ( seq hash -- seq hash' )
over byte-array? little-endian? and [
[ 0 over length 4 - 4 <range> ] dip
[ pick <displaced-alien> int deref (main-loop) ] reduce
] [
[ dup length 4 mod dupd head-slice* 4 <groups> ] dip
[ le> (main-loop) ] reduce
] if ; inline
: end-case ( seq hash -- hash' )
swap dup length 4 mod [ tail-slice* ] keep {
[ drop ]
[
first + [ 10 shift ] [ bitxor ] bi 32 bits
[ -1 shift ] [ + ] bi
]
[
le> + [ 11 shift ] [ bitxor ] bi 32 bits
[ -17 shift ] [ + ] bi
]
[
unclip-last-slice
[ le> + [ 16 shift ] [ bitxor ] bi ]
[ 18 shift bitxor ] bi* 32 bits
[ -11 shift ] [ + ] bi
]
} dispatch ; inline
: avalanche ( hash -- hash' )
[ 3 shift ] [ bitxor ] bi 32 bits [ -5 shift ] [ + ] bi
[ 4 shift ] [ bitxor ] bi 32 bits [ -17 shift ] [ + ] bi
[ 25 shift ] [ bitxor ] bi 32 bits [ -6 shift ] [ + ] bi ; inline
PRIVATE>
M: superfast checksum-bytes
seed>> 32 bits main-loop end-case avalanche ;

1
basis/checksums/xxhash/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

1
basis/checksums/xxhash/summary.txt Normal file
View File

@ -0,0 +1 @@
xxHash checksum algorithm

11
basis/checksums/xxhash/xxhash-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.xxhash
HELP: xxhash
{ $class-description "xxHash 32-bit checksum algorithm." } ;
ARTICLE: "checksums.xxhash" "XxHash checksum"
"xxHash is a non-cryptographic hash function suitable for general hash-based lookup."
{ $subsections xxhash } ;
ABOUT: "checksums.xxhash"

8
basis/checksums/xxhash/xxhash-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: byte-arrays checksums tools.test ;
IN: checksums.xxhash
{ 1584409650 } [ "asdf" 0 <xxhash> checksum-bytes ] unit-test
{ 4257502458 } [ "Hello World!" 12345 <xxhash> checksum-bytes ] unit-test
{ 1584409650 } [ "asdf" >byte-array 0 <xxhash> checksum-bytes ] unit-test
{ 4257502458 } [ "Hello World!" >byte-array 12345 <xxhash> checksum-bytes ] unit-test

74
basis/checksums/xxhash/xxhash.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2014 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data byte-arrays
checksums combinators generalizations grouping io.binary kernel
locals math math.bitwise math.ranges sequences ;
IN: checksums.xxhash
CONSTANT: prime1 2654435761
CONSTANT: prime2 2246822519
CONSTANT: prime3 3266489917
CONSTANT: prime4 668265263
CONSTANT: prime5 374761393
TUPLE: xxhash seed ;
C: <xxhash> xxhash
<PRIVATE
:: native-mapper ( from to bytes c-type -- seq )
from to bytes <slice>
bytes byte-array? little-endian? and
[ c-type cast-array ]
[ c-type heap-size <groups> [ le> ] map ] if ; inline
PRIVATE>
M:: xxhash checksum-bytes ( bytes checksum -- value )
checksum seed>> :> seed
bytes length :> len
len dup 16 mod - :> len/16
len dup 4 mod - :> len/4
len 16 >= [
seed prime1 w+ prime2 w+
seed prime2 w+
seed
seed prime1 w-
0 len/16 bytes uint native-mapper
4 <groups> [
first4
[ prime2 w* w+ 13 bitroll-32 prime1 w* ]
4 napply
] each
{
[ 1 bitroll-32 ]
[ 7 bitroll-32 ]
[ 12 bitroll-32 ]
[ 18 bitroll-32 ]
} spread w+ w+ w+
] [
seed prime5 w+
] if
len w+
len/16 len/4 bytes uint native-mapper
[ prime3 w* w+ 17 bitroll-32 prime4 w* ] each
bytes len/4 tail-slice
[ prime5 w* w+ 11 bitroll-32 prime1 w* ] each
[ -15 shift ] [ bitxor ] bi prime2 w*
[ -13 shift ] [ bitxor ] bi prime3 w*
[ -16 shift ] [ bitxor ] bi ;
INSTANCE: xxhash checksum

10
basis/circular/circular-docs.factor
View File

@ -55,6 +55,14 @@ HELP: circular-while
}
{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;
HELP: circular-loop
{ $values
{ "circular" circular }
{ "quot" quotation }
}
{ $description "Calls " { $snippet "quot" } " on each element of the sequence until one call yields " { $link f } "." }
{ $notes "This rotates the " { $link circular } " object after each call, so the next element to be applied will always be the first element." } ;
ARTICLE: "circular" "Circular sequences"
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
"Creating a new circular object:"
@ -74,6 +82,6 @@ ARTICLE: "circular" "Circular sequences"
growing-circular-push
}
"Iterating over a circular until a stop condition:"
{ $subsections circular-while } ;
{ $subsections circular-while circular-loop } ;
ABOUT: "circular"

36
basis/circular/circular-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private
circular strings ;
USING: arrays circular kernel math sequences sequences.private
strings tools.test ;
IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
@ -42,3 +42,35 @@ IN: circular.tests
swap growing-circular-push
] with each >array
] unit-test
[ V{ 1 2 3 } ] [
{ 1 2 3 } <circular> V{ } [
[ push f ] curry circular-while
] keep
] unit-test
CONSTANT: test-sequence1 { t f f f }
[ V{ 1 2 3 1 } ] [
{ 1 2 3 } <circular> V{ } [
[ [ push ] [ length 1 - test-sequence1 nth ] bi ] curry circular-while
] keep
] unit-test
CONSTANT: test-sequence2 { t f t t f f t t t f f f }
[ V{ 1 2 3 1 2 3 1 2 3 1 2 3 } ] [
{ 1 2 3 } <circular> V{ } [
[ [ push ] [ length 1 - test-sequence2 nth ] bi ] curry circular-while
] keep
] unit-test
[ V{ 1 2 3 1 2 } ] [
{ 1 2 3 } <circular> V{ } [
[ [ push ] [ length 5 < ] bi ] curry circular-loop
] keep
] unit-test
[ V{ 1 } ] [
{ 1 2 3 } <circular> V{ } [
[ push f ] curry circular-loop
] keep
] unit-test

7
basis/circular/circular.factor
View File

@ -60,14 +60,14 @@ TUPLE: circular-iterator
{ circular read-only } { n integer } { last-start integer } ;
: <circular-iterator> ( circular -- obj )
0 0 circular-iterator boa ; inline
0 -1 circular-iterator boa ; inline
<PRIVATE
: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + ] bi = [
2drop
] [
[ [ 1 + ] change-n ] dip (circular-while)
@ -77,3 +77,6 @@ PRIVATE>
: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
: circular-loop ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip '[ [ first @ ] [ rotate-circular ] bi ] curry loop ; inline

4
basis/classes/struct/struct.factor
View File

@ -250,7 +250,9 @@ M: struct-bit-slot-spec compute-slot-offset
PRIVATE>
M: struct byte-length class-of "struct-size" word-prop ; inline foldable
: struct-size ( class -- n ) "struct-size" word-prop ; inline
M: struct byte-length class-of struct-size ; inline foldable
M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inline
! class definition

13
basis/cocoa/apple-script/apple-script-docs.factor Normal file
View File

@ -0,0 +1,13 @@
USING: help.markup help.syntax strings ;
IN: cocoa.apple-script
HELP: run-apple-script
{ $values { "str" string } }
{ $description "Runs the provided uncompiled AppleScript code." }
{ $notes "Currently, return values are unsupported." } ;
HELP: APPLESCRIPT:
{ $syntax "APPLESCRIPT: word ...applescript... ;APPLESCRIPT" }
{ $values { "word" "a new word to define" } { "...applescript..." "AppleScript source text" } }
{ $description "Defines a word that when called will run the provided uncompiled AppleScript. The word has stack effect " { $snippet "( -- )" } " due to return values being currently unsupported." } ;

16
basis/cocoa/apple-script/apple-script.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2013 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: cocoa cocoa.application cocoa.classes kernel parser
multiline words ;
IN: cocoa.apple-script
: run-apple-script ( str -- )
[ NSAppleScript -> alloc ] dip
<NSString> -> initWithSource: -> autorelease
f -> executeAndReturnError: drop ;
SYNTAX: APPLESCRIPT:
scan-new-word ";APPLESCRIPT" parse-multiline-string
[ run-apple-script ] curry ( -- ) define-declared ;

1
basis/cocoa/apple-script/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

1
basis/cocoa/apple-script/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

17
basis/cocoa/cocoa.factor
View File

@ -1,17 +1,15 @@
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation.bundles namespaces assocs hashtables
compiler.units lexer init ;
USING: cocoa.messages compiler.units core-foundation.bundles
hashtables init io kernel lexer namespaces sequences vocabs ;
FROM: cocoa.messages => selector ;
IN: cocoa
SYMBOL: sent-messages
: (remember-send) ( selector variable -- )
[ dupd ?set-at ] change-global ;
SYMBOL: sent-messages
: remember-send ( selector -- )
sent-messages (remember-send) ;
@ -22,12 +20,6 @@ SYNTAX: SEL:
[ remember-send ]
[ <selector> suffix! \ selector suffix! ] bi ;
SYNTAX: SEND:
scan-token
[ remember-send ]
[ <selector> suffix! \ selector suffix! ]
[ suffix! \ lookup-sender suffix! ] tri ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
@ -52,6 +44,7 @@ SYNTAX: IMPORT: scan-token [ ] import-objc-class ;
[
{
"NSAlert"
"NSAppleScript"
"NSApplication"
"NSArray"
"NSAutoreleasePool"

9
basis/cocoa/enumeration/enumeration.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data
locals math sequences vectors fry libc destructors specialized-arrays ;
USING: accessors alien.data assocs classes.struct cocoa
cocoa.runtime cocoa.types destructors fry hashtables kernel libc
locals sequences specialized-arrays vectors ;
SPECIALIZED-ARRAY: id
IN: cocoa.enumeration
@ -32,3 +33,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
: NSFastEnumeration>vector ( object -- vector )
[ ] NSFastEnumeration-map ;
: NSFastEnumeration>hashtable ( ... object quot: ( ... elt -- ... key value ) -- ... vector )
NS-EACH-BUFFER-SIZE <hashtable>
[ '[ @ swap _ set-at ] NSFastEnumeration-each ] keep ; inline

2
basis/cocoa/messages/messages-docs.factor
View File

@ -31,7 +31,7 @@ HELP: alien>objc-types
{ objc>alien-types alien>objc-types } related-words
HELP: import-objc-class
{ $values { "name" string } { "quot" { $quotation "( -- )" } } }
{ $values { "name" string } { "quot" { $quotation ( -- ) } } }
{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class

8
basis/cocoa/messages/messages-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: alien.c-types cocoa.runtime tools.test ;
IN: cocoa.messages
{ "( sender-stub:void() )" }
[ { void { } } sender-stub-name ] unit-test
{ "( sender-stub:id(id,SEL,void*,Class) )" }
[ { id { id SEL void* Class } } sender-stub-name ] unit-test

19
basis/cocoa/messages/messages.factor
View File

@ -14,8 +14,13 @@ SPECIALIZED-ARRAY: void*
: make-sender ( signature function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub ( name signature function -- word )
[ "( sender-stub:" ")" surround f <word> dup ] 2dip
: sender-stub-name ( signature -- str )
first2 [ name>> ] [
[ name>> ] map "," join "(" ")" surround
] bi* append "( sender-stub:" " )" surround ;
: sender-stub ( signature function -- word )
[ [ sender-stub-name f <word> dup ] keep ] dip
over first large-struct? [ "_stret" append ] when
make-sender dup infer define-declared ;
@ -25,13 +30,13 @@ SYMBOL: super-message-senders
message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize
:: cache-stub ( name signature function assoc -- )
signature assoc [ [ name ] dip function sender-stub ] cache drop ;
:: cache-stub ( signature function assoc -- )
signature assoc [ function sender-stub ] cache drop ;
: cache-stubs ( name signature -- )
: cache-stubs ( signature -- )
[ "objc_msgSendSuper" super-message-senders get cache-stub ]
[ "objc_msgSend" message-senders get cache-stub ]
2bi ;
bi ;
: <super> ( receiver -- super )
[ ] [ object_getClass class_getSuperclass ] bi
@ -224,7 +229,7 @@ ERROR: no-objc-type name ;
: register-objc-method ( method -- )
[ method-name ]
[ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
[ cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
[ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
: each-method-in-class ( class quot -- )
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip

6
basis/cocoa/nibs/nibs-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax strings ;
USING: help.markup help.syntax sequences strings ;
IN: cocoa.nibs
HELP: load-nib
@ -11,6 +11,6 @@ HELP: nib-named
{ $see-also nib-objects } ;
HELP: nib-objects
{ $values { "anNSNib" "an instance of NSNib" } { "objects/f" "a sequence" } }
{ $values { "anNSNib" "an instance of NSNib" } { "objects/f" { $maybe sequence } } }
{ $description "Instantiates the top-level objects of the " { $snippet ".nib" } " file loaded by anNSNib. First create an NSNib instance using " { $link nib-named } "." }
{ $see-also nib-named } ;
{ $see-also nib-named } ;

4
basis/cocoa/pasteboard/pasteboard-docs.factor
View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax strings ;
USING: help.markup help.syntax kernel strings ;
IN: cocoa.pasteboard
HELP: pasteboard-string?
{ $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" "a boolean" } }
{ $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" boolean } }
{ $description "Tests if the pasteboard holds a string." } ;
HELP: pasteboard-string

4
basis/cocoa/plists/plists.factor
View File

@ -30,8 +30,8 @@ DEFER: plist>
[ plist> ] NSFastEnumeration-map ;
: (plist-NSDictionary>) ( NSDictionary -- hashtable )
dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ 2array ] with
NSFastEnumeration-map >hashtable ;
dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ ] with
NSFastEnumeration>hashtable ;
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f

8
basis/colors/colors.factor
View File

@ -16,11 +16,11 @@ C: <rgba> rgba
GENERIC: >rgba ( color -- rgba )
M: rgba >rgba ( rgba -- rgba ) ; inline
M: rgba >rgba ; inline
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
M: color red>> >rgba red>> ;
M: color green>> >rgba green>> ;
M: color blue>> >rgba blue>> ;
: >rgba-components ( object -- r g b a )
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline

6
basis/colors/gray/gray.factor
View File

@ -16,7 +16,11 @@ M: gray green>> gray>> ;
M: gray blue>> gray>> ;
: rgba>gray ( rgba -- gray )
GENERIC: >gray ( color -- gray )
M: object >gray >rgba >gray ;
M: rgba >gray
>rgba-components [
[ 0.3 * ] [ 0.59 * ] [ 0.11 * ] tri* + +
] dip <gray> ;

10
basis/colors/hsv/hsv.factor
View File

@ -49,7 +49,13 @@ M: hsva >rgba ( hsva -- rgba )
PRIVATE>
:: rgba>hsva ( rgba -- hsva )
GENERIC: >hsva ( color -- hsva )
M: object >hsva >rgba >hsva ;
M: hsva >hsva ; inline
M:: rgba >hsva ( rgba -- hsva )
rgba >rgba-components :> ( r g b a )
r g b sort-triple :> ( z y x )
x z = x zero? or [ 0 0 x a <hsva> ] [
@ -64,7 +70,7 @@ PRIVATE>
] if ;
: complimentary-color ( color -- color' )
dup hsva? [ >rgba rgba>hsva ] unless
dup hsva? [ >hsva ] unless
{
[ hue>> 180 + 360 mod ]
[ saturation>> ]

8
basis/combinators/short-circuit/short-circuit.factor
View File

@ -29,8 +29,8 @@ PRIVATE>
: 0&& ( quots -- ? ) [ ] unoptimized-&& ;
: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
: 2&& ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-&& ;
MACRO: n|| ( quots n -- quot )
[
@ -51,5 +51,5 @@ PRIVATE>
: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;
: 2|| ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-|| ;
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-|| ;

2
basis/combinators/smart/smart-docs.factor
View File

@ -228,7 +228,7 @@ HELP: smart-when*
HELP: smart-with
{ $values
{ "param" object } { "obj" object } { "quot" { $quotation "( param ..a -- ..b" } } { "curry" curry } }
{ "param" object } { "obj" object } { "quot" { $quotation "( param ..a -- ..b )" } } { "curry" curry } }
{ $description "A version of " { $link with } " that puts the parameter before any inputs the quotation uses." } ;
HELP: smart-reduce

2
basis/combinators/smart/smart.factor
View File

@ -67,7 +67,7 @@ M: object infer-known* drop f ;
: output>array ( quot -- array )
{ } output>sequence ; inline
: cleave>array ( x seq -- array )
: cleave>array ( obj quots -- array )
'[ _ cleave ] output>array ; inline
: cleave>sequence ( x seq exemplar -- array )

32
basis/command-line/command-line-tests.factor Normal file
View File

@ -0,0 +1,32 @@
USING: namespaces splitting tools.test ;
IN: command-line
{ f { "a" "b" "c" } } [
{ "-run=test-voc" "a" "b" "c" } parse-command-line
script get command-line get
] unit-test
{ f { "-a" "b" "c" } } [
{ "-run=test-voc" "-a" "b" "c" } parse-command-line
script get command-line get
] unit-test
{ f { "a" "-b" "c" } } [
{ "-run=test-voc" "a" "-b" "c" } parse-command-line
script get command-line get
] unit-test
{ f { "a" "b" "-c" } } [
{ "-run=test-voc" "a" "b" "-c" } parse-command-line
script get command-line get
] unit-test
{ "a" { "b" "c" } } [
{ "a" "b" "c" } parse-command-line
script get command-line get
] unit-test
{ "a" { "b" "c" } } [
{ "-foo" "a" "b" "c" } parse-command-line
script get command-line get
] unit-test

19
basis/command-line/command-line.factor
View File

@ -62,18 +62,21 @@ SYMBOL: command-line
[ source-file main>> [ execute( -- ) ] when* ] bi
] with-variable ;
: (parse-command-line) ( run? args -- )
[ command-line off script off drop ] [
unclip "-" ?head
[ param (parse-command-line) ]
[
rot [ prefix f ] when
: (parse-command-line) ( args -- )
[
unclip "-" ?head [
[ param ] [ "run=" head? ] bi
[ command-line set ]
[ (parse-command-line) ] if
] [
script set command-line set
] if
] if-empty ;
] unless-empty ;
: parse-command-line ( args -- )
[ [ "-run=" head? ] any? ] keep (parse-command-line) ;
command-line off
script off
(parse-command-line) ;
SYMBOL: main-vocab-hook

6
basis/compiler/cfg/block-joining/block-joining-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: compiler.cfg help.markup help.syntax ;
IN: compiler.cfg.block-joining
HELP: join-block?
{ $values { "bb" basic-block } { "?" "a boolean" } }
{ $description "Whether the block can be joined with its predecessor or not." } ;

2
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -44,7 +44,7 @@ IN: compiler.cfg.branch-splitting
: update-successor-predecessors ( copies old-bb -- )
dup successors>>
[ update-successor-predecessor ] with with each ;
[ update-successor-predecessor ] 2with each ;
: split-branch ( bb -- )
[ new-blocks ] keep

21
basis/compiler/cfg/builder/alien/alien-docs.factor Normal file
View File

@ -0,0 +1,21 @@
USING: help.markup help.syntax literals make multiline stack-checker.alien ;
IN: compiler.cfg.builder.alien
<<
STRING: ex-caller-return
USING: compiler.cfg.builder.alien make prettyprint ;
[
T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } } ,
T{ alien-invoke-params { return pointer: void } } caller-return
] { } make .
{
T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } }
T{ ##box-alien { dst 116 } { src 1 } { temp 115 } }
}
;
>>
HELP: caller-return
{ $values { "params" alien-node-params } }
{ $description "If the last alien call returns a value, then this word will emit an instruction to the current sequence being constructed by " { $link make } " that boxes it." }
{ $examples { $unchecked-example $[ ex-caller-return ] } } ;

52
basis/compiler/cfg/builder/alien/boxing/boxing-docs.factor Normal file
View File

@ -0,0 +1,52 @@
USING: alien.c-types compiler.cfg.instructions help.markup help.syntax make
math ;
IN: compiler.cfg.builder.alien.boxing
HELP: box
{ $values
{ "vregs" "a one-element sequence containing a virtual register indentifier" }
{ "reps" "a one-element sequence containing a representation symbol" }
{ "c-type" c-type }
{ "dst" "box" }
}
{ $description "Emits a " { $link ##box-alien } " instruction which boxes an alien value contained in the given register." }
{ $examples
{ $unchecked-example
"USING: compiler.cfg.builder.alien.boxing make prettyprint ;"
"{ 71 } { int-rep } void* base-type [ box ] { } make nip ."
"{ T{ ##box-alien { dst 105 } { src 71 } { temp 104 } } }"
}
}
{ $see-also ##box-alien } ;
HELP: box-return
{ $values
{ "vregs" "vregs that contains the return value of the alien call" }
{ "reps" "representations of the vregs" }
{ "c-type" abstract-c-type }
{ "dst" "vreg in which the boxed value, or a reference to it, will be placed" }
}
{ $description "Emits instructions for boxing the return value from an alien function call." }
{ $examples
{ $unchecked-example
"USING: compiler.cfg.builder.alien.boxing kernel make prettyprint ;"
"[ { 10 } { tagged-rep } int base-type box-return drop ] { } make ."
"{ T{ ##convert-integer { dst 118 } { src 10 } { c-type int } } }"
}
}
{ $see-also ##box-alien } ;
HELP: stack-size
{ $values
{ "c-type" c-type }
{ "n" number }
}
{ $description "Calculates how many bytes of stack space an instance of the C type requires." }
{ $examples
{ $unchecked-example
"USING: compiler.cfg.builder.alien.boxing prettyprint vm ;"
"context base-type stack-size ."
"144"
}
}
{ $see-also heap-size } ;

17
basis/compiler/cfg/builder/alien/params/params-docs.factor Normal file
View File

@ -0,0 +1,17 @@
USING: cpu.architecture help.markup help.syntax math ;
IN: compiler.cfg.builder.alien.params
HELP: stack-params
{ $var-description "Count of the number of bytes of stack allocation required to store the current call frames parameters." } ;
HELP: alloc-stack-param
{ $values { "rep" representation } { "n" integer } }
{ $description "Allocates space for a stack parameter value of the given representation and returns the previous stack parameter offset." }
{ $examples
"On 32-bit architectures, the offsets will be aligned to four byte boundaries."
{ $unchecked-example
"0 stack-params set float-rep alloc-stack-param stack-params get . ."
"4"
"0"
}
} ;

2
basis/compiler/cfg/builder/alien/params/params.factor
View File

@ -6,7 +6,7 @@ IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
GENERIC: alloc-stack-param ( reg -- n )
GENERIC: alloc-stack-param ( rep -- n )
M: object alloc-stack-param ( rep -- n )
stack-params get

55
basis/compiler/cfg/builder/blocks/blocks-docs.factor Normal file
View File

@ -0,0 +1,55 @@
USING: compiler.cfg compiler.tree help.markup help.syntax literals math
multiline quotations ;
IN: compiler.cfg.builder.blocks
<<
STRING: ex-emit-trivial-block
USING: compiler.cfg.builder.blocks prettyprint ;
initial-basic-block [ [ gensym ##call, ] emit-trivial-block ] { } make drop
basic-block get .
T{ basic-block
{ id 2040412 }
{ successors
V{
T{ basic-block
{ id 2040413 }
{ instructions
V{
T{ ##call { word ( gensym ) } }
T{ ##branch }
}
}
{ successors
V{ T{ basic-block { id 2040414 } } }
}
}
}
}
}
;
>>
HELP: begin-basic-block
{ $description "Terminates the current block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ;
HELP: call-height
{ $values { "#call" #call } { "n" number } }
{ $description "Calculates how many items a " { $link #call } " will add or remove from the data stack." }
{ $examples
{ $example
"USING: compiler.cfg.builder.blocks compiler.tree.builder prettyprint sequences ;"
"[ 3append ] build-tree second call-height ."
"-2"
}
} ;
HELP: emit-trivial-block
{ $values { "quot" quotation } }
{ $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." }
{ $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ;
HELP: initial-basic-block
{ $description "Creates an initial empty " { $link basic-block } " and stores it in the basic-block dynamic variable." } ;
HELP: make-kill-block
{ $description "Marks the current " { $link basic-block } " being processed as a kill block." } ;

82
basis/compiler/cfg/builder/builder-docs.factor Normal file
View File

@ -0,0 +1,82 @@
USING: assocs compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.stacks.local compiler.tree help.markup help.syntax literals math
multiline sequences words ;
IN: compiler.cfg.builder
<<
STRING: ex-emit-call
USING: compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.stacks
kernel make prettyprint ;
begin-stack-analysis initial-basic-block \ dummy 3 [ emit-call ] { } make drop
current-height basic-block [ get . ] bi@ .
T{ current-height { d 3 } }
T{ basic-block
{ id 134 }
{ successors
V{
T{ basic-block
{ id 135 }
{ instructions
V{
T{ ##call { word dummy } }
T{ ##branch }
}
}
{ successors V{ T{ basic-block { id 136 } } } }
{ kill-block? t }
}
}
}
}
;
STRING: ex-make-input-map
USING: compiler.cfg.builder prettyprint ;
T{ #shuffle { in-d { 37 81 92 } } } make-input-map .
H{
{ 81 T{ ds-loc { n 1 } } }
{ 37 T{ ds-loc { n 2 } } }
{ 92 T{ ds-loc } }
}
;
>>
HELP: procedures
{ $var-description "Used as a temporary storage for the current cfg during construction of all cfgs." } ;
HELP: make-input-map
{ $values { "#shuffle" #shuffle } { "assoc" assoc } }
{ $description "Creates an " { $link assoc } " that maps input values to the shuffle operation to stack locations." }
{ $examples { $unchecked-example $[ ex-make-input-map ] } } ;
HELP: emit-call
{ $values { "word" word } { "height" number } }
{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link current-height } " variables." }
{ $examples
"In this example, a call to a dummy word is emitted which pushes three items onto the stack."
{ $unchecked-example $[ ex-emit-call ] }
}
{ $see-also call-height } ;
HELP: emit-node
{ $values { "node" node } }
{ $description "Emits CFG instructions for the given SSA node." } ;
HELP: trivial-branch?
{ $values
{ "nodes" "a " { $link sequence } " of " { $link node } " instances" }
{ "value" "the pushed value or " { $link f } }
{ "?" "a boolean" }
}
{ $description "Checks whether nodes is a trivial branch or not. The branch is counted as trivial if all it does is push a literal value on the stack." }
{ $examples
{ $example
"USING: compiler.cfg.builder compiler.tree prettyprint ;"
"{ T{ #push { literal 25 } } } trivial-branch? . ."
"t\n25"
}
} ;
HELP: build-cfg
{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } }
{ $description "Builds one or more cfgs from the given word." } ;

36
basis/compiler/cfg/cfg-docs.factor Normal file
View File

@ -0,0 +1,36 @@
USING: compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.stack-frame compiler.tree help.markup help.syntax namespaces
sequences vectors words ;
IN: compiler.cfg
HELP: basic-block
{ $class-description
"Factors representation of a basic block in the Call Flow Graph (CFG). A basic block is a sequence of instructions that always are executed sequentially and doesn't contain any branching. It has the following slots:"
{ $table
{ { $slot "successors" } { "A " { $link vector } " of basic blocks that may be executed directly after this block. Most blocks only have one successor but a block that checks where an if-condition should branch to would have two for example." } }
{ { $slot "predecessors" } { "The opposite of successors -- a " { $link vector } " of basic blocks from which the execution may have arrived into this block." } }
{ { $slot "instructions" } { "A " { $link vector } " of " { $link insn } " tuples which form the instructions of the basic block." } }
{ { $slot "unlikely?" } { "Unused boolean slot." } }
}
} ;
HELP: <basic-block>
{ $values { "bb" basic-block } }
{ $description "Creates a new empty basic block. The " { $slot "id" } " slot is initialized with the value of the basic-block " { $link counter } "." } ;
HELP: cfg
{ $class-description
"Call flow graph. It has the following slots:"
{ $table
{ { $slot "entry" } { "Root " { $link basic-block } " of the graph." } }
{ { $slot "word" } { "The " { $link word } " the cfg is produced from." } }
{ { $slot "post-order" } { "The blocks of the cfg in a post order traversal " { $link sequence } "." } }
{ { $slot "stack-frame" } { { $link stack-frame } " of the cfg." } }
{ { $slot "frame-pointer?" } { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link #alien-callback } " nodes does need it." } }
}
}
{ $see-also post-order } ;
HELP: cfg-changed
{ $values { "cfg" cfg } }
{ $description "Resets all \"calculated\" slots in the cfg which forces them to be recalculated." } ;

52
basis/compiler/cfg/dataflow-analysis/dataflow-analysis-docs.factor Normal file
View File

@ -0,0 +1,52 @@
USING: classes compiler.cfg help.markup help.syntax sequences ;
IN: compiler.cfg.dataflow-analysis
HELP: predecessors
{ $values { "bb" basic-block } { "dfa" "a dataflow analysis symbol" } { "seq" sequence } }
{ $description "Generic word that returns the predecessors for a block. It's purpose is to facilitate backward analysis in which the blocks successors are seen as the predecessors." } ;
HELP: successors
{ $values { "bb" basic-block } { "dfa" "a dataflow analysis symbol" } { "seq" sequence } }
{ $description "Generic word that returns the successors for a block. It's purpose is to facilitate backward analysis in which the blocks predecessors are seen as the successors." } ;
HELP: transfer-set
{ $values
{ "in-set" "input state" }
{ "bb" basic-block }
{ "dfa" class }
{ "out-set" "output state" }
}
{ $description "Generic word which is called during the dataflow analysis to process each basic block in the cfg. It is supposed to be implemented by all forward and backward dataflow analysis subclasses to perform analysis." } ;
HELP: join-sets
{ $values
{ "sets" "input states" }
{ "bb" basic-block }
{ "dfa" class }
{ "set" "merged state" }
}
{ $description "Generic word which merges multiple states into one. A block in the cfg might have multiple predecessors and then this word is used to compute the merged input state to use to analyze the block." } ;
<PRIVATE
HELP: run-dataflow-analysis
{ $values
{ "cfg" cfg }
{ "dfa" "a dataflow analysis symbol" }
{ "in-sets" "inputs" }
{ "out-sets" "outputs" }
}
{ $description "Runs the given dataflow analysis on the cfg." } ;
PRIVATE>
HELP: FORWARD-ANALYSIS:
{ $syntax "FORWARD-ANALYSIS: word" }
{ $values { "word" "name of the compiler pass" } }
{ $description "Syntax word for defining a forward analysis compiler pass." } ;
HELP: BACKWARD-ANALYSIS:
{ $syntax "BACKWARD-ANALYSIS: word" }
{ $values { "word" "name of the compiler pass" } }
{ $description "Syntax word for defining a backward analysis compiler pass." } ;

6
basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
View File

@ -10,6 +10,7 @@ GENERIC: transfer-set ( in-set bb dfa -- out-set )
GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
GENERIC: predecessors ( bb dfa -- seq )
GENERIC: ignore-block? ( bb dfa -- ? )
<PRIVATE
@ -20,7 +21,7 @@ MIXIN: dataflow-analysis
:: compute-in-set ( bb out-sets dfa -- set )
! Only consider initialized sets.
bb kill-block?>> [ f ] [
bb dfa ignore-block? [ f ] [
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
@ -32,7 +33,7 @@ MIXIN: dataflow-analysis
bb in-sets maybe-set-at ; inline
:: compute-out-set ( bb in-sets dfa -- set )
bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
bb dfa ignore-block? [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
:: update-out-set ( bb in-sets out-sets dfa -- ? )
bb in-sets dfa compute-out-set
@ -55,6 +56,7 @@ MIXIN: dataflow-analysis
out-sets ; inline
M: dataflow-analysis join-sets 2drop assoc-refine ;
M: dataflow-analysis ignore-block? drop kill-block?>> ;
FUNCTOR: define-analysis ( name -- )

24
basis/compiler/cfg/def-use/def-use-docs.factor Normal file
View File

@ -0,0 +1,24 @@
USING: compiler.cfg.instructions help.markup help.syntax sequences ;
IN: compiler.cfg.def-use
HELP: defs-vregs
{ $values { "insn" insn } { "seq" sequence } }
{ $description "Returns the sequence of vregs defined, or introduced, by this instruction." }
{ $examples
{ $example
"USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;"
"T{ ##peek f 37 D 0 0 } defs-vregs ."
"{ 37 }"
}
} ;
HELP: uses-vregs
{ $values { "insn" insn } { "seq" sequence } }
{ $description "Returns the sequence of vregs used by this instruction." }
{ $examples
{ $example
"USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;"
"T{ ##replace f 37 D 1 6 } uses-vregs ."
"{ 37 }"
}
} ;

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -109,7 +109,7 @@ SYMBOLS: defs insns ;
: insn-of ( vreg -- insn ) insns get at ;
: set-def-of ( obj insn assoc -- )
swap defs-vregs [ swap set-at ] with with each ;
swap defs-vregs [ swap set-at ] 2with each ;
: compute-defs ( cfg -- )
H{ } clone [

6
basis/compiler/cfg/dependence/dependence-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: compiler.cfg.instructions help.markup help.syntax sequences ;
IN: compiler.cfg.dependence
HELP: <node>
{ $values { "insn" insn } { "node" node } }
{ $description "Creates a new dependency graph node from an CFG instruction." } ;

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