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

Merge branch 'master' into experimental 

Conflicts:
	basis/http/client/client.factor
db4
Alex Chapman 2009-04-14 10:42:41 +10:00
parent ace909795d 6efbe50543
commit f2596259dd
1055 changed files with 29965 additions and 6108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
Factor.app/Contents/Frameworks/libfreetype.6.dylib
View File

Binary file not shown.

62
Makefile
View File

@ -4,12 +4,14 @@ LD = ld
EXECUTABLE = factor
CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92
IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g
@ -35,7 +37,6 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/debug.o \
vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
@ -48,6 +49,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS)
TEST_OBJS = vm/ffi_test.o
default:
$(MAKE) `./build-support/factor.sh make-target`
@ -81,70 +84,67 @@ help:
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64
macosx-freetype:
ln -sf libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.dylib
macosx-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-ppc: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-32: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.64
macosx-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.ppc
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.arm
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@ -161,13 +161,19 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
factor-ffi-test: vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib}
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<

6
README.txt
View File

@ -113,12 +113,6 @@ the command prompt using the console application:
factor.com -i=boot.<cpu>.image
Before bootstrapping, you will need to download the DLLs for the Pango
text rendering library. The required DLLs are listed in
build-support/dlls.txt and are available from the following location:
<http://factorcode.org/dlls>
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.

4
basis/alien/c-types/c-types-docs.factor
View File

@ -217,6 +217,8 @@ $nl
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
@ -243,4 +245,6 @@ $nl
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;

2
basis/alien/c-types/c-types-tests.factor
View File

@ -4,7 +4,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
\ expand-constants must-infer
: xyz 123 ;
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test

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

@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations fry call classes ;
accessors combinators effects continuations fry classes ;
IN: alien.c-types
DEFER: <int>

30
basis/alien/destructors/destructors-docs.factor Normal file
View File

@ -0,0 +1,30 @@
IN: alien.destructors
USING: help.markup help.syntax alien destructors ;
HELP: DESTRUCTOR:
{ $syntax "DESTRUCTOR: word" }
{ $description "Defines four things:"
{ $list
{ "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
{ "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
{ "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
}
"The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
}
{ $examples
"Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
{ $code
"FUNCTION: void g_object_unref ( gpointer object ) ;"
"DESTRUCTOR: g_object_unref"
}
"Now, memory management becomes easier:"
{ $code
"[ g_new_foo &g_object_unref ... ] with-destructors"
}
} ;
ARTICLE: "alien.destructors" "Alien destructors"
"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
{ $subsection POSTPONE: DESTRUCTOR: } ;
ABOUT: "alien.destructors"

8
basis/alien/destructors/destructors.factor Normal file → Executable file
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors destructors accessors kernel parser words ;
USING: functors destructors accessors kernel parser words
effects generalizations sequences ;
IN: alien.destructors
SLOT: alien
@ -11,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}
N [ F stack-effect out>> length ]
WHERE
@ -18,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
M: F-destructor dispose* alien>> F ;
M: F-destructor dispose* alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
@ -26,4 +28,4 @@ M: F-destructor dispose* alien>> F ;
;FUNCTOR
: DESTRUCTOR: scan-word define-destructor ; parsing
SYNTAX: DESTRUCTOR: scan-word define-destructor ;

8
basis/alien/fortran/fortran-docs.factor
View File

@ -7,10 +7,10 @@ IN: alien.fortran
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
{ $list
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
{ { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
{ { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
{ { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
{ { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
}
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;

23
basis/alien/fortran/fortran.factor
View File

@ -5,10 +5,10 @@ byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system ;
math.order sorting strings system alien.libraries ;
IN: alien.fortran
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
M: g95-abi real-functions-return-double? f ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
M: g95-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
M: g95-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;
HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;
@ -416,7 +421,7 @@ PRIVATE>
: define-fortran-record ( name vocab fields -- )
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
: RECORD: scan in get parse-definition define-fortran-record ; parsing
SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
@ -437,16 +442,16 @@ MACRO: fortran-invoke ( return library function parameters -- )
return library function parameters return [ "void" ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
: SUBROUTINE:
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
[ "()" subseq? not ] filter define-fortran-function ;
: FUNCTION:
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
[ "()" subseq? not ] filter define-fortran-function ;
: LIBRARY:
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ set-fortran-abi ] bi ; parsing
[ set-fortran-abi ] bi ;

0
basis/opengl/glu/authors.txt → basis/alien/libraries/authors.txt
View File

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

@ -0,0 +1,60 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax assocs help.markup
help.syntax io.backend kernel namespaces ;
IN: alien.libraries
HELP: <library>
{ $values
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ "library" library } }
{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
{ $values { "name" "a string" } { "library" "a hashtable" } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
{ { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
}
} ;
HELP: dlopen ( path -- dll )
{ $values { "path" "a pathname string" } { "dll" "a DLL handle" } }
{ $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
{ $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
HELP: dlsym ( name dll -- alien )
{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" "an alien pointer" } }
{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable." }
{ $errors "Throws an error if the symbol could not be found." } ;
HELP: dlclose ( dll -- )
{ $values { "dll" "a DLL handle" } }
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
$nl
"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." }
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" [ drop ]"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;

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

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien assocs io.backend kernel namespaces ;
IN: alien.libraries
SYMBOL: libraries
libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll )
library dup [ dll>> ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;

38
basis/alien/structs/fields/fields.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private math namespaces
make sequences strings words effects combinators alien.c-types ;
@ -6,28 +6,6 @@ IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;
: reader-effect ( type spec -- effect )
[ 1array ] [ name>> 1array ] bi* <effect> ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over reader>>
swap "declared-effect" set-word-prop
reader>> swap "reading" set-word-prop ;
: writer-effect ( type spec -- effect )
name>> swap 2array 0 <effect> ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over writer>>
swap "declared-effect" set-word-prop
writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word )
[ "-" glue ] dip create ;
@ -55,17 +33,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: define-struct-slot-word ( word quot spec effect -- )
[ offset>> prefix ] dip define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ reader>> ]
[ type>> c-type-getter-boxer ]
[ ] tri
: define-getter ( spec -- )
[ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
(( c-ptr -- value )) define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
: define-setter ( spec -- )
[ writer>> ] [ type>> c-setter ] [ ] tri
(( value c-ptr -- )) define-struct-slot-word ;
: define-field ( type spec -- )
[ define-getter ] [ define-setter ] 2bi ;
: define-field ( spec -- )
[ define-getter ] [ define-setter ] bi ;

2
basis/alien/structs/structs-tests.factor
View File

@ -24,7 +24,7 @@ os winnt? cpu x86? and [
] when
] when
: MAX_FOOS 30 ;
CONSTANT: MAX_FOOS 30
C-STRUCT: foox
{ { "int" MAX_FOOS } "x" } ;

22
basis/alien/structs/structs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
@ -56,10 +56,10 @@ M: struct-type stack-size
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type new
swap >>fields
swap >>align
swap >>size
swap typedef ;
swap >>fields
swap >>align
swap >>size
swap typedef ;
: make-fields ( name vocab fields -- fields )
[ first2 <field-spec> ] with with map ;
@ -68,12 +68,11 @@ M: struct-type stack-size
[ c-type-align ] [ max ] map-reduce ;
: define-struct ( name vocab fields -- )
[
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
] [ 2drop '[ _ swap define-field ] ] 3bi each ;
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
[ define-field ] each ;
: define-union ( name members -- )
[ expand-constants ] map
@ -83,4 +82,3 @@ M: struct-type stack-size
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;

33
basis/alien/syntax/syntax.factor
View File

@ -4,38 +4,37 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser words.constant ;
fry vocabs.parser words.constant alien.libraries ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
: ALIEN: scan string>number <alien> parsed ; parsing
SYNTAX: ALIEN: scan string>number <alien> parsed ;
: BAD-ALIEN <bad-alien> parsed ; parsing
SYNTAX: BAD-ALIEN <bad-alien> parsed ;
: LIBRARY: scan "c-library" set ; parsing
SYNTAX: LIBRARY: scan "c-library" set ;
: FUNCTION:
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
define-function ; parsing
define-function ;
: TYPEDEF:
scan scan typedef ; parsing
SYNTAX: TYPEDEF:
scan scan typedef ;
: C-STRUCT:
scan in get parse-definition define-struct ; parsing
SYNTAX: C-STRUCT:
scan in get parse-definition define-struct ;
: C-UNION:
scan parse-definition define-union ; parsing
SYNTAX: C-UNION:
scan parse-definition define-union ;
: C-ENUM:
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
parsing
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
: &:
scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;

0
extra/promises/tags.txt → basis/alien/syntax/tags.txt
View File

3
basis/base64/base64-tests.factor
View File

@ -23,5 +23,8 @@ IN: base64.tests
ascii encode >base64-lines >string
] unit-test
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
\ >base64 must-infer
\ base64> must-infer

6
basis/base64/base64.factor
View File

@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
ERROR: malformed-base64 ;
<PRIVATE
: read1-ignoring ( ignoring -- ch )
@ -25,7 +27,7 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
} nth ; inline
} nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
@ -48,8 +50,6 @@ SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
ERROR: malformed-base64 ;
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*

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

@ -14,7 +14,7 @@ $nl
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words

11
basis/binary-search/binary-search.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators hints arrays ;
@ -16,14 +16,19 @@ IN: binary-search
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
decide {
{ +eq+ [ finish ] }
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
{ +lt+ [ [ (head) ] keep-searching ] }
{ +gt+ [ [ (tail) ] keep-searching ] }
} case
] if ; inline recursive

2
basis/bit-arrays/bit-arrays.factor
View File

@ -68,7 +68,7 @@ M: bit-array resize
M: bit-array byte-length length 7 + -3 shift ;
: ?{ \ } [ >bit-array ] parse-literal ; parsing
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array )
dup 0 = [

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -3,7 +3,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each ;
[ t ] [

2
basis/bit-vectors/bit-vectors.factor
View File

@ -31,7 +31,7 @@ M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;

2
basis/bootstrap/help/help.factor
View File

@ -5,7 +5,7 @@ IN: bootstrap.help
: load-help ( -- )
"help.lint" require
"tools.vocabs.browser" require
"help.vocabs" require
"alien.syntax" require
"compiler" require

15
basis/bootstrap/image/image.factor
View File

@ -95,10 +95,10 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad )
[ { } make ] 3dip 4array ; inline
[ [ call( -- ) ] { } make ] 3dip 4array ;
: jit-define ( quot rc rt offset name -- )
[ make-jit ] dip set ; inline
[ make-jit ] dip set ;
: define-sub-primitive ( quot rc rt offset word -- )
[ make-jit ] dip sub-primitives get set-at ;
@ -398,9 +398,14 @@ M: byte-array '
] emit-object ;
! Tuples
ERROR: tuple-removed class ;
: require-tuple-layout ( word -- layout )
dup tuple-layout [ ] [ tuple-removed ] ?if ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
@ -446,6 +451,8 @@ M: quotation '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt
0 emit ! code
] emit-object
@ -515,7 +522,7 @@ M: quotation '
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Building generic words..." print flush
call-remake-generics-hook
remake-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush

14
basis/bootstrap/stage2.factor
View File

@ -30,7 +30,7 @@ SYMBOL: bootstrap-time
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap count number>string write ;
all-words swap count number>string write ; inline
: print-time ( ms -- )
1000 /i
@ -45,11 +45,18 @@ SYMBOL: bootstrap-time
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
: save/restore-error ( quot -- )
error get-global
error-continuation get-global
[ call ] 2dip
error-continuation set-global
error set-global ; inline
[
! We time bootstrap
millis
@ -104,6 +111,7 @@ SYMBOL: bootstrap-time
drop
[
load-help? off
"vocab:bootstrap/bootstrap-error.factor" run-file
[ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error
call
] with-scope
] recover

1
basis/bootstrap/tools/tools.factor
View File

@ -14,7 +14,6 @@ IN: bootstrap.tools
"tools.time"
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"tools.vocabs.monitor"
"editors"
} [ require ] each

8
basis/bootstrap/ui/ui.factor
View File

@ -10,12 +10,4 @@ IN: bootstrap.ui
{ [ os unix? ] [ "x11" ] }
} cond
] unless* "ui.backend." prepend require
"ui-text-backend" get [
{
{ [ os macosx? ] [ "core-text" ] }
{ [ os windows? ] [ "pango" ] }
{ [ os unix? ] [ "pango" ] }
} cond
] unless* "ui.text." prepend require
] when

2
basis/byte-vectors/byte-vectors-tests.factor
View File

@ -4,7 +4,7 @@ prettyprint ;
[ 0 ] [ 123 <byte-vector> length ] unit-test
: do-it
: do-it ( seq -- seq )
123 [ over push ] each ;
[ t ] [

2
basis/byte-vectors/byte-vectors.factor
View File

@ -42,7 +42,7 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ;
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

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

@ -5,7 +5,8 @@
! License: http://factorcode.org/license.txt
USING: system combinators alien alien.syntax alien.c-types
alien.destructors kernel accessors sequences arrays ui.gadgets ;
alien.destructors kernel accessors sequences arrays ui.gadgets
alien.libraries ;
IN: cairo.ffi
<< {

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

@ -36,7 +36,7 @@ HELP: month-name
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
@ -54,7 +54,7 @@ HELP: day-name
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
@ -62,7 +62,7 @@ HELP: day-abbreviation2
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3

2
basis/calendar/calendar-tests.factor
View File

@ -148,7 +148,7 @@ IN: calendar.tests
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
: checktime+ now dup clone [ rot time+ drop ] keep = ;
: checktime+ ( duration -- ? ) now dup clone [ rot time+ drop ] keep = ;
[ t ] [ 5 seconds checktime+ ] unit-test

28
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader threads accessors combinators
locals classes.tuple math.order summary combinators.short-circuit ;
USING: accessors arrays classes.tuple combinators combinators.short-circuit
kernel locals math math.functions math.order namespaces sequences strings
summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@ -39,8 +39,10 @@ M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
PRIVATE>
: month-names ( -- array )
@ -52,11 +54,11 @@ PRIVATE>
: month-name ( n -- string )
check-month 1- month-names nth ;
: month-abbreviations ( -- array )
CONSTANT: month-abbreviations
{
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
} ;
}
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
@ -70,17 +72,17 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-name ( n -- string ) day-names nth ;
: day-abbreviations2 ( -- array )
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
CONSTANT: day-abbreviations2
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
: day-abbreviation2 ( n -- string )
day-abbreviations2 nth ;
day-abbreviations2 nth ; inline
: day-abbreviations3 ( -- array )
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
CONSTANT: day-abbreviations3
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ;
day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
@ -134,7 +136,7 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
dup 100 mod zero? 400 4 ? mod zero? ;
dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
@ -346,7 +348,7 @@ M: duration time-
#! good for any date since October 15, 1582
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;

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

@ -46,6 +46,11 @@ IN: calendar.format
: 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 -- )

47
basis/call/call-docs.factor
View File

@ -1,47 +0,0 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations effects words call.private ;
IN: call
ABOUT: "call"
ARTICLE: "call" "Calling code with known stack effects"
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
$nl
"Quotations:"
{ $subsection POSTPONE: call( }
{ $subsection call-effect }
"Words:"
{ $subsection POSTPONE: execute( }
{ $subsection execute-effect }
"Unsafe calls:"
{ $subsection POSTPONE: execute-unsafe( }
{ $subsection execute-effect-unsafe } ;
HELP: call(
{ $syntax "call( stack -- effect )" }
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
HELP: call-effect
{ $values { "quot" quotation } { "effect" effect } }
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
HELP: execute(
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
HELP: execute-effect
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
HELP: execute-unsafe(
{ $syntax "execute-unsafe( stack -- effect )" }
{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." }
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
HELP: execute-effect-unsafe
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ;
{ call-effect execute-effect execute-effect-unsafe } related-words
{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words

25
basis/call/call-tests.factor
View File

@ -1,25 +0,0 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math tools.test call call.private kernel accessors ;
IN: call.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
[ 1 2 [ + ] call( -- z ) ] must-fail
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
[ [ + ] call( x y -- z ) ] must-infer
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
[ 1 2 \ + execute( -- z ) ] must-fail
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test optimized>> ] unit-test
[ 4 ] [ 1 3 compile-execute(-test ] unit-test

42
basis/call/call.factor
View File

@ -1,42 +0,0 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros fry summary sequences generalizations accessors
continuations effects effects.parser parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
M: wrong-values summary
drop "Wrong number of values returned from quotation" ;
<PRIVATE
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-effect-unsafe? ( word effect -- ? )
swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
PRIVATE>
MACRO: call-effect ( effect -- quot )
[ in>> length ] [ out>> length ] bi
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
: call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- )
2dup execute-effect-unsafe?
[ execute-effect-unsafe ]
[ [ [ execute ] curry ] dip call-effect ]
if ; inline
: execute( \ execute-effect parse-call( ; parsing

1
basis/call/summary.txt
View File

@ -1 +0,0 @@
Calling arbitrary quotations and executing arbitrary words with a static stack effect

2
basis/cocoa/application/application.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private
cocoa.runtime sequences init summary kernel.private
assocs ;
IN: cocoa.application

2
basis/cocoa/cocoa-tests.factor
View File

@ -13,7 +13,7 @@ CLASS: {
[ gc "x" set 2drop ]
} ;
: test-foo
: test-foo ( -- )
Foo -> alloc -> init
dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
-> release ;

12
basis/cocoa/cocoa.factor
View File

@ -14,18 +14,14 @@ SYMBOL: sent-messages
: remember-send ( selector -- )
sent-messages (remember-send) ;
: ->
scan dup remember-send parsed \ send parsed ;
parsing
SYNTAX: -> scan dup remember-send parsed \ send parsed ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
super-sent-messages (remember-send) ;
: SUPER->
scan dup remember-super-send parsed \ super-send parsed ;
parsing
SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
SYMBOL: frameworks
@ -33,9 +29,9 @@ frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
: IMPORT: scan [ ] import-objc-class ; parsing
SYNTAX: IMPORT: scan [ ] import-objc-class ;
"Compiling Objective C bridge..." print

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

@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien stack-checker kernel
math namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
libc.private parser lexer init core-foundation fry generalizations
specialized-arrays.direct.alien call ;
specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -22,15 +22,13 @@ SYMBOL: super-message-senders
message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize
: cache-stub ( method function hash -- )
[
over get [ 2drop ] [ over [ sender-stub ] dip set ] if
] bind ;
: cache-stub ( method assoc function -- )
'[ _ sender-stub ] cache drop ;
: cache-stubs ( method -- )
dup
"objc_msgSendSuper" super-message-senders get cache-stub
"objc_msgSend" message-senders get cache-stub ;
[ super-message-senders get "objc_msgSendSuper" cache-stub ]
[ message-senders get "objc_msgSend" cache-stub ]
bi ;
: <super> ( receiver -- super )
"objc-super" <c-object> [

6
basis/cocoa/subclassing/subclassing.factor
View File

@ -8,7 +8,7 @@ IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
[ sel_registerName ] [ execute ] [ utf8 string>alien ]
[ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
tri* ;
: throw-if-false ( obj what -- )
@ -76,6 +76,6 @@ SYMBOL: +superclass+
import-objc-class
] bind ;
: CLASS:
SYNTAX: CLASS:
parse-definition unclip
>hashtable define-objc-class ; parsing
>hashtable define-objc-class ;

2
basis/cocoa/views/views.factor
View File

@ -89,4 +89,4 @@ PRIVATE>
-> locationInWindow f -> convertPoint:fromView:
[ CGPoint-x ] [ CGPoint-y ] bi
] [ drop -> frame CGRect-h ] 2bi
swap - 2array ;
swap - [ >integer ] bi@ 2array ;

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

@ -23,7 +23,7 @@ $nl
ARTICLE: "colors" "Colors"
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
$nl
"RGBA colors:"
"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
{ $subsection rgba }
{ $subsection <rgba> }
"Converting a color to RGBA:"

2
basis/colors/constants/constants.factor
View File

@ -30,4 +30,4 @@ ERROR: no-such-color name ;
: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
: COLOR: scan named-color parsed ; parsing
SYNTAX: COLOR: scan named-color parsed ;

1
basis/combinators/short-circuit/smart/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

1
basis/combinators/short-circuit/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

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

@ -108,17 +108,19 @@ HELP: append-outputs-as
ARTICLE: "combinators.smart" "Smart combinators"
"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
"Smart inputs from a sequence:"
"The macros in the " { $vocab-link "combinators.smart" } " vocabulary look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
"Call a quotation and discard all output values:"
{ $subsection drop-outputs }
"Take all input values from a sequence:"
{ $subsection input<sequence }
"Smart outputs to a sequence:"
"Store all output values to a sequence:"
{ $subsection output>sequence }
{ $subsection output>array }
"Reducing the output of a quotation:"
"Reducing the set of output values:"
{ $subsection reduce-outputs }
"Summing the output of a quotation:"
"Summing output values:"
{ $subsection sum-outputs }
"Appending the results of a quotation:"
"Concatenating output values:"
{ $subsection append-outputs }
{ $subsection append-outputs-as } ;

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

@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order
stack-checker math ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
dup infer out>> '[ @ _ ndrop ] ;
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;

1
basis/combinators/smart/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

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

@ -54,13 +54,12 @@ SYMBOL: main-vocab-hook
embedded? [
"alien.remote-control"
] [
main-vocab-hook get [ call ] [ "listener" ] if*
main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
] if ;
: default-cli-args ( -- )
global [
"quiet" off
"script" off
"e" off
"user-init" on
embedded? "quiet" set

4
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -13,10 +13,10 @@ IN: compiler.cfg.instructions.syntax
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
: INSN:
SYNTAX: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; parsing
3tri ;

2
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -99,7 +99,7 @@ SYMBOL: spill-counts
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.

6
basis/compiler/cfg/registers/registers.factor
View File

@ -17,6 +17,6 @@ C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
: V scan-word scan-word vreg boa parsed ; parsing
: D scan-word <ds-loc> parsed ; parsing
: R scan-word <rs-loc> parsed ; parsing
SYNTAX: V scan-word scan-word vreg boa parsed ;
SYNTAX: D scan-word <ds-loc> parsed ;
SYNTAX: R scan-word <rs-loc> parsed ;

6
basis/compiler/codegen/codegen.factor
View File

@ -3,7 +3,7 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc
alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture
compiler.errors
compiler.alien
@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? compiling-word get f ? add-literal drop ;
compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate ( mr -- asm )
[
@ -464,7 +464,7 @@ TUPLE: callback-context ;
dup current-callback eq? [
drop
] [
yield-hook get call wait-to-return
yield-hook get call( -- ) wait-to-return
] if ;
: do-callback ( quot token -- )

32
basis/compiler/codegen/fixup/fixup.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
@ -28,51 +28,47 @@ M: label-fixup fixup*
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
TUPLE: rel-fixup class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
[ type>> ]
[ class>> ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
{ 0 24 28 } bitfield
relocation-table get push-4 ;
M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-literal ( obj -- ) literal-table get push ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol ] dip 2array literal-table get push-all ;
[ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-dlsym ( name dll class -- )
[ literal-table get length [ add-dlsym-literals ] dip ] dip
rt-dlsym rel-fixup ;
[ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first ] dip rt-primitive rel-fixup ;
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
: rel-immediate ( literal class -- )
[ add-literal ] dip rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
rt-this rel-fixup ;
: rel-here ( offset class -- )
rt-here rel-fixup ;
[ add-literal ] dip rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set

7
basis/compiler/compiler-docs.factor
View File

@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"
{ $subsection disable-compiler }
{ $subsection enable-compiler }
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
@ -46,9 +44,8 @@ HELP: (compile)
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." }
HELP: optimizing-compiler
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: compile-call

19
basis/compiler/compiler.factor
View File

@ -35,11 +35,14 @@ SYMBOLS: +optimized+ +unoptimized+ ;
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word status -- ? )
swap "compiled-status" word-prop [ = not ] keep and ;
: ripple-up? ( status word -- ? )
[
[ nip changed-effects get key? ]
[ "compiled-status" word-prop eq? not ] 2bi or
] keep "compiled-status" word-prop and ;
: save-compiled-status ( word status -- )
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ over ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-status" set-word-prop ]
2bi ;
@ -111,7 +114,7 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield-hook get call ] slurp-deque ;
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
@ -119,7 +122,9 @@ t compile-dependencies? set-global
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
: optimized-recompile-hook ( words -- alist )
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
@ -129,10 +134,10 @@ t compile-dependencies? set-global
] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
optimizing-compiler compiler-impl set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;

6
basis/compiler/constants/constants.factor
View File

@ -20,10 +20,10 @@ CONSTANT: deck-bits 18
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
@ -42,7 +42,7 @@ CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-here 4
CONSTANT: rt-label 5
CONSTANT: rt-this 5
CONSTANT: rt-immediate 6
CONSTANT: rt-stack-chain 7

29
basis/compiler/tests/alien.factor Normal file → Executable file
View File

@ -1,10 +1,27 @@
IN: compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
specialized-arrays.float ;
specialized-arrays.float alien.libraries io.pathnames
io.backend ;
IN: compiler.tests
<<
: libfactor-ffi-tests-path ( -- string )
"resource:" (normalize-path)
{
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
>>
LIBRARY: f-cdecl
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -107,9 +124,7 @@ unit-test
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
<< "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test
[ f ] [ "f-stdcall" load-library f = ] unit-test
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
@ -149,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
"int"
f "ffi_test_31"
"f-cdecl" "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
@ -157,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
"float"
f "ffi_test_31_point_5"
"f-cdecl" "ffi_test_31_point_5"
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
alien-invoke ;

6
basis/compiler/tests/intrinsics.factor
View File

@ -270,7 +270,7 @@ cell 8 = [
] when
! Some randomized tests
: compiled-fixnum* fixnum* ;
: compiled-fixnum* ( a b -- c ) fixnum* ;
[ ] [
10000 [
@ -281,7 +281,7 @@ cell 8 = [
] times
] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
: compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
@ -293,7 +293,7 @@ cell 8 = [
] times
] unit-test
: compiled-bignum>fixnum bignum>fixnum ;
: compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
[ ] [
10000 [

26
basis/compiler/tests/optimizer.factor
View File

@ -13,7 +13,7 @@ M: array xyz xyz ;
[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
: pred-test-1 ( a -- b c )
dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if
] [
@ -24,7 +24,7 @@ M: array xyz xyz ;
TUPLE: pred-test ;
: pred-test-2
: pred-test-2 ( a -- b c )
dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if
] [
@ -33,7 +33,7 @@ TUPLE: pred-test ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3
: pred-test-3 ( a -- b c )
dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if
] [
@ -42,14 +42,14 @@ TUPLE: pred-test ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test
: inline-test ( a -- b )
"nom" = ;
[ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
: fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test
@ -61,13 +61,13 @@ TUPLE: pred-test ;
! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ;
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline recursive
: bad-kill-2 ( a b -- c d ) bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
@ -77,7 +77,7 @@ TUPLE: pred-test ;
< [
6 1 (double-recursion)
3 2 (double-recursion)
] when ; inline
] when ; inline recursive
: double-recursion ( -- ) 0 2 (double-recursion) ;
@ -85,7 +85,7 @@ TUPLE: pred-test ;
! regression
: double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
! regression
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
@ -224,7 +224,7 @@ USE: binary-search.private
] unit-test
! Regression
: empty-compound ;
: empty-compound ( -- ) ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
@ -293,7 +293,7 @@ HINTS: recursive-inline-hang-3 array ;
! Wow
: counter-example ( a b c d -- a' b' c' d' )
dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive
: counter-example' ( -- a' b' c' d' )
1 2 3.0 3 counter-example ;

20
basis/compiler/tests/redefine15.factor Normal file
View File

@ -0,0 +1,20 @@
USING: compiler.units words tools.test math kernel ;
IN: compiler.tests.redefine15
DEFER: word-1
: word-2 ( a -- b ) word-1 ;
[ \ word-1 [ ] (( a -- b )) define-declared ] with-compilation-unit
[ "a" ] [ "a" word-2 ] unit-test
: word-3 ( a -- b ) 1 + ;
: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
[ 1 1 ] [ 0 word-4 ] unit-test
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
[ 2 3 ] [ 0 word-4 ] unit-test

4
basis/compiler/tests/redefine2.factor
View File

@ -1,12 +1,14 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval ;
arrays words assocs eval words.symbol ;
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test
[ t ] [ redefine2-test new sequence? ] unit-test
[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test

2
basis/compiler/tests/stack-trace.factor
View File

@ -14,7 +14,7 @@ words splitting grouping sorting accessors ;
[ t ] [
symbolic-stack-trace
[ word? ] filter
{ baz bar foo throw } tail?
{ baz bar foo } tail?
] unit-test
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;

4
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -90,7 +90,7 @@ M: object xyz ;
[ swap [ call 1+ ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ t ] [
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [
[ { bignum } declare annotate-entry-test-2 ]

5
basis/compiler/tree/debugger/debugger-tests.factor
View File

@ -1,5 +1,8 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test ;
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
\ optimized. must-infer
\ optimizer-report. must-infer
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.

4
basis/compiler/tree/debugger/debugger.factor
View File

@ -130,8 +130,6 @@ M: node node>quot drop ;
GENERIC: optimized. ( quot/word -- )
M: method-spec optimized. first2 method optimized. ;
M: word optimized. specialized-def optimized. ;
M: callable optimized. build-tree optimize-tree nodes>quot . ;
@ -160,7 +158,7 @@ SYMBOL: node-count
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
} cond inc-at
} cond get inc-at
] [ drop ] if
] each-node
node-count set

2
basis/compiler/tree/propagation/info/info.factor
View File

@ -238,7 +238,7 @@ DEFER: (value-info-union)
: value-infos-union ( infos -- info )
[ null-info ]
[ unclip-slice [ value-info-union ] reduce ] if-empty ;
[ [ ] [ value-info-union ] map-reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{

4
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order call
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -312,7 +312,7 @@ generic-comparison-ops [
\ clone [
in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] }
{ H{ } [ [ drop hashtable new ] ] }
{ H{ } [ [ drop 0 <hashtable> ] ] }
[ drop f ]
} case
] "custom-inlining" set-word-prop

2
basis/compression/zlib/ffi/ffi.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system ;
USING: alien alien.syntax combinators system alien.libraries ;
IN: compression.zlib.ffi
<< "zlib" {

4
basis/concurrency/conditions/conditions.factor
View File

@ -20,10 +20,12 @@ IN: concurrency.conditions
]
] dip later ;
ERROR: wait-timeout ;
: wait ( queue timeout status -- )
over [
[ queue-timeout [ drop ] ] dip suspend
[ "Timeout" throw ] [ cancel-alarm ] if
[ wait-timeout ] [ cancel-alarm ] if
] [
[ drop '[ _ push-front ] ] dip suspend drop
] if ;

16
basis/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -1,6 +1,6 @@
IN: concurrency.mailboxes.tests
USING: concurrency.mailboxes concurrency.count-downs vectors
sequences threads tools.test math kernel strings namespaces
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ;
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
@ -75,3 +75,15 @@ continuations calendar destructors ;
[ ] [ "d" get 5 seconds await-timeout ] unit-test
[ ] [ "m" get dispose ] unit-test
[ { "foo" "bar" } ] [
<mailbox>
"foo" over mailbox-put
"bar" over mailbox-put
mailbox-get-all
] unit-test
[
<mailbox> 1 seconds mailbox-get-timeout
] [ wait-timeout? ] must-fail-with

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? ]
[ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;

6
basis/constructors/constructors.factor
View File

@ -16,8 +16,8 @@ MACRO: set-slots ( slots -- quot )
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
define-declared ;
: CONSTRUCTOR:
SYNTAX: CONSTRUCTOR:
scan-word [ name>> "<" ">" surround create-in ] keep
"(" expect ")" parse-effect
complete-effect
parse-definition
define-constructor ; parsing
define-constructor ;

2
basis/core-foundation/fsevents/fsevents.factor
View File

@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks
eventFlags numEvents <direct-int-array>
eventIds numEvents <direct-longlong-array>
3array flip
info event-stream-callbacks get at [ drop ] or call ;
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
: master-event-source-callback ( -- alien )
"void"

4
basis/core-foundation/strings/strings.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors unicode.data ;
core-foundation.arrays destructors ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: prepare-CFString ( string -- byte-array )
[
dup HEX: 10ffff >
[ drop CHAR: replacement-character ] when
[ drop HEX: fffd ] when
] map utf8 encode ;
: <CFString> ( string -- alien )

7
basis/core-text/utilities/utilities.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words parser alien alien.c-types kernel fry accessors ;
USING: words parser alien alien.c-types kernel fry accessors
alien.libraries ;
IN: core-text.utilities
: C-GLOBAL:
SYNTAX: C-GLOBAL:
CREATE-WORD
dup name>> '[ _ f dlsym *void* ]
(( -- value )) define-declared ; parsing
(( -- value )) define-declared ;

28
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -21,7 +21,7 @@ IN: cpu.ppc.assembler.backend
: define-d-insn ( word opcode -- )
[ d-insn ] curry (( d a simm -- )) define-declared ;
: D: CREATE scan-word define-d-insn ; parsing
SYNTAX: D: CREATE scan-word define-d-insn ;
: sd-insn ( d a simm opcode -- )
[ s>u16 { 0 21 16 } bitfield ] dip insn ;
@ -29,7 +29,7 @@ IN: cpu.ppc.assembler.backend
: define-sd-insn ( word opcode -- )
[ sd-insn ] curry (( d a simm -- )) define-declared ;
: SD: CREATE scan-word define-sd-insn ; parsing
SYNTAX: SD: CREATE scan-word define-sd-insn ;
: i-insn ( li aa lk opcode -- )
[ { 0 1 0 } bitfield ] dip insn ;
@ -40,26 +40,26 @@ IN: cpu.ppc.assembler.backend
: (X) ( -- word quot )
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
: X: (X) (( a s b -- )) define-declared ; parsing
SYNTAX: X: (X) (( a s b -- )) define-declared ;
: (1) ( quot -- quot' ) [ 0 ] prepose ;
: X1: (X) (1) (( a s -- )) define-declared ; parsing
SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
: xfx-insn ( d spr xo opcode -- )
[ { 1 11 21 } bitfield ] dip insn ;
: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
: MFSPR:
SYNTAX: MFSPR:
CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
(( d -- )) define-declared ;
: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
: MTSPR:
SYNTAX: MTSPR:
CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
(( d -- )) define-declared ;
: xo-insn ( d a b oe rc xo opcode -- )
[ { 1 0 10 11 16 21 } bitfield ] dip insn ;
@ -68,9 +68,9 @@ IN: cpu.ppc.assembler.backend
CREATE scan-word scan-word scan-word scan-word
[ xo-insn ] 2curry 2curry ;
: XO: (XO) (( a s b -- )) define-declared ; parsing
SYNTAX: XO: (XO) (( a s b -- )) define-declared ;
: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
@ -84,11 +84,11 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
: BC:
SYNTAX: BC:
CREATE-B scan-word scan-word
[ rot BC ] 2curry (( c -- )) define-declared ; parsing
[ rot BC ] 2curry (( c -- )) define-declared ;
: B:
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
[ b-insn ] curry curry curry curry curry
(( bo -- )) define-declared ; parsing
(( bo -- )) define-declared ;

6
basis/cpu/ppc/bootstrap.factor
View File

@ -11,8 +11,8 @@ big-endian on
4 jit-code-format set
: ds-reg 29 ;
: rs-reg 30 ;
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
: factor-area-size ( -- n ) 4 bootstrap-cells ;
@ -41,7 +41,7 @@ big-endian on
stack-frame 6 LI
6 1 next-save STW
0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
[
0 6 LOAD32

39
basis/cpu/ppc/ppc.factor
View File

@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
heap-size 7 LI
"box_medium_struct" f %alien-invoke ;
M: ppc %unbox-small-struct
drop "No small structs" throw ;
: %unbox-struct-1 ( -- )
! Alien must be in r3.
"alien_offset" f %alien-invoke
3 3 0 LWZ ;
: %unbox-struct-2 ( -- )
! Alien must be in r3.
"alien_offset" f %alien-invoke
4 3 4 LWZ
3 3 0 LWZ ;
: %unbox-struct-4 ( -- )
! Alien must be in r3.
"alien_offset" f %alien-invoke
6 3 12 LWZ
5 3 8 LWZ
4 3 4 LWZ
3 3 0 LWZ ;
M: ppc %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
{ 4 [ %unbox-struct-4 ] }
} case ;
USE: vocabs.loader
@ -673,3 +700,5 @@ USE: vocabs.loader
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
"complex-double" c-type t >>return-in-registers? drop

3
basis/cpu/x86/32/32.factor
View File

@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
check_sse2 ;
"-no-sse2" (command-line) member? [
[ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
"Checking if your CPU supports SSE2..." print flush
sse2? [

3
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -11,5 +11,4 @@ IN: cpu.x86.assembler.syntax
: define-registers ( names size -- )
'[ _ define-register ] each-index ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ;

2
basis/cpu/x86/bootstrap.factor
View File

@ -32,7 +32,7 @@ big-endian off
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
[
! load literal

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

@ -279,7 +279,7 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators"
"SQLite example combinator:"
{ $code <"
USING: db.sqlite db io.files ;
USING: db.sqlite db io.files io.files.temp ;
: with-sqlite-db ( quot -- )
"my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }

2
basis/db/db.factor
View File

@ -149,4 +149,4 @@ M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;
] with-variable ; inline

5
basis/db/errors/sqlite/sqlite.factor
View File

@ -4,7 +4,8 @@ USING: accessors combinators db kernel sequences peg.ebnf
strings db.errors ;
IN: db.errors.sqlite
ERROR: unparsed-sqlite-error error ;
TUPLE: unparsed-sqlite-error error ;
C: <unparsed-sqlite-error> unparsed-sqlite-error
SINGLETONS: table-exists table-missing ;
@ -22,4 +23,6 @@ SqliteError =
=> [[ table >string message sqlite-table-error ]]
| "no such table: " .+:table
=> [[ table >string <sql-table-missing> ]]
| .*:error
=> [[ error >string <unparsed-sqlite-error> ]]
;EBNF

2
basis/db/postgresql/ffi/ffi.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;
USING: alien alien.syntax combinators system alien.libraries ;
IN: db.postgresql.ffi
<< "postgresql" {

5
basis/db/queries/queries.factor
View File

@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
db.private ;
db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
M: byte-array where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;

2
basis/db/sqlite/ffi/ffi.factor
View File

@ -3,7 +3,7 @@
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators alien.c-types ;
system combinators alien.c-types alien.libraries ;
IN: db.sqlite.ffi
<< "sqlite" {

25
basis/db/tuples/tuples-tests.factor
View File

@ -285,7 +285,7 @@ paste "PASTE"
[ test-cascade ] test-postgresql
[ test-restrict ] test-postgresql
: test-repeated-insert
: test-repeated-insert ( -- )
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
@ -458,7 +458,7 @@ TUPLE: bignum-test id m n o ;
swap >>n
swap >>m ;
: test-bignum
: test-bignum ( -- )
bignum-test "BIGNUM_TEST"
{
{ "id" "ID" +db-assigned-id+ }
@ -478,7 +478,7 @@ TUPLE: bignum-test id m n o ;
TUPLE: secret n message ;
C: <secret> secret
: test-random-id
: test-random-id ( -- )
secret "SECRET"
{
{ "n" "ID" +random-id+ system-random-generator }
@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO"
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
TUPLE: example id data ;
example "EXAMPLE"
{
{ "id" "ID" +db-assigned-id+ }
{ "data" "DATA" BLOB }
} define-persistent
: test-blob-select ( -- )
example ensure-table
[ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
[
T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
[ test-blob-select ] test-sqlite
[ test-blob-select ] test-postgresql

3
basis/debugger/debugger-docs.factor
View File

@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations io.files.private listener ;
help generic.standard continuations io.files.private listener
alien.libraries ;
IN: debugger
ARTICLE: "debugger" "The debugger"

2
basis/debugger/debugger.factor
View File

@ -325,3 +325,5 @@ M: bad-literal-tuple summary drop "Bad literal tuple" ;
M: check-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;

12
basis/definitions/icons/icons-docs.factor Normal file
View File

@ -0,0 +1,12 @@
IN: definitions.icons
USING: help.markup help.syntax ;
ARTICLE: "definitions.icons" "Definition icons"
"The " { $vocab-link "definitions.icons" } " vocabulary associates common definition types with icons."
{ $definition-icons }
"Looking up the icon associated with a definition:"
{ $subsection definition-icon }
"Defining new icons:"
{ $subsection POSTPONE: ICON: } ;
ABOUT: "definitions.icons"

38
basis/definitions/icons/icons.factor
View File

@ -2,22 +2,29 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes.predicate fry generic io.pathnames kernel
macros sequences vocabs words words.symbol words.constant
lexer parser help.topics ;
lexer parser help.topics help.markup namespaces sorting ;
IN: definitions.icons
GENERIC: definition-icon ( definition -- path )
<PRIVATE
: definition-icon-path ( string -- string' )
"resource:basis/definitions/icons/" prepend-path ".tiff" append ;
"vocab:definitions/icons/" prepend-path ".tiff" append ;
<<
: ICON:
scan-word \ definition-icon create-method
scan '[ drop _ definition-icon-path ]
define ; parsing
SYMBOL: icons
icons [ H{ } clone ] initialize
: define-icon ( class name -- )
[ swap icons get set-at ]
[
[ \ definition-icon create-method ]
[ '[ drop _ definition-icon-path ] ] bi*
define
] 2bi ;
SYNTAX: ICON: scan-word scan define-icon ;
>>
@ -29,12 +36,15 @@ ICON: primitive primitive-word
ICON: symbol symbol-word
ICON: constant constant-word
ICON: word normal-word
ICON: vocab-link unopen-vocab
ICON: word-link word-help-article
ICON: link help-article
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
PRIVATE>
M: vocab definition-icon
vocab-main "runnable-vocab" "open-vocab" ? definition-icon-path ;
: $definition-icons ( element -- )
drop
icons get >alist sort-keys
[ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
{ "" "Definition class" } prefix
$table ;

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