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

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

release import-0.92
nomennescio 2019-10-18 15:05:24 +02:00
parent 49e769e48c a495f8e099
commit f1e1c66812
9209 changed files with 868691 additions and 132969 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.cvskeywords
View File

@ -1,6 +1,4 @@
./extra/xmode/modes/java.xml: <!-- for the common usage of the cvs keyword $Id: java.xml 9228 2007-03-27 22:01:25Z ezust $ --> ./basis/xmode/modes/java.xml: <!-- for the common usage of the cvs keyword $Id: java.xml 9228 2007-03-27 22:01:25Z ezust $ -->
./extra/xmode/modes/fortran.xml: Version $Id: fortran.xml 10573 2007-09-14 02:04:59Z ezust $ ./basis/xmode/modes/fortran.xml: Version $Id: fortran.xml 10573 2007-09-14 02:04:59Z ezust $
./extra/xmode/modes/nsis2.xml:$Id: nsis2.xml 9932 2007-07-06 15:44:46Z Vampire0 $ ./basis/xmode/modes/nsis2.xml:$Id: nsis2.xml 9932 2007-07-06 15:44:46Z Vampire0 $
./extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup.js:// $Id: calendar-setup.js,v 1.25 2005/03/07 09:51:33 mishoo Exp $ ./vm/bignumint.hpp:$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
./extra/webapps/article-manager/resources/jscalendar-1.0/calendar.js:// $Id: calendar.js,v 1.51 2005/03/07 16:44:31 mishoo Exp $
./vm/bignumint.h:$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $

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

@ -32,7 +32,7 @@
<key>CFBundlePackageType</key> <key>CFBundlePackageType</key>
<string>APPL</string> <string>APPL</string>
<key>NSHumanReadableCopyright</key> <key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2007, Slava Pestov and friends</string> <string>Copyright © 2003-2009, Slava Pestov and friends</string>
<key>NSServices</key> <key>NSServices</key>
<array> <array>
<dict> <dict>

55
Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib generated
View File

@ -1,17 +1,38 @@
{ <?xml version="1.0" encoding="UTF-8"?>
IBClasses = ( <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
{ <plist version="1.0">
ACTIONS = { <dict>
newFactorWorkspace = id; <key>IBClasses</key>
runFactorFile = id; <array>
saveFactorImage = id; <dict>
saveFactorImageAs = id; <key>ACTIONS</key>
showFactorHelp = id; <dict>
}; <key>factorBrowser</key>
CLASS = FirstResponder; <string>id</string>
LANGUAGE = ObjC; <key>factorListener</key>
SUPERCLASS = NSObject; <string>id</string>
} <key>newFactorBrowser</key>
); <string>id</string>
IBVersion = 1; <key>newFactorListener</key>
} <string>id</string>
<key>refreshAll</key>
<string>id</string>
<key>runFactorFile</key>
<string>id</string>
<key>saveFactorImage</key>
<string>id</string>
<key>saveFactorImageAs</key>
<string>id</string>
</dict>
<key>CLASS</key>
<string>FirstResponder</string>
<key>LANGUAGE</key>
<string>ObjC</string>
<key>SUPERCLASS</key>
<string>NSObject</string>
</dict>
</array>
<key>IBVersion</key>
<string>1</string>
</dict>
</plist>

21
Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib generated
View File

@ -1,21 +1,16 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0"> <plist version="1.0">
<dict> <dict>
<key>IBDocumentLocation</key>
<string>557 119 525 491 0 0 2560 1578 </string>
<key>IBEditorPositions</key>
<dict>
<key>29</key>
<string>326 905 270 44 0 0 2560 1578 </string>
</dict>
<key>IBFramework Version</key> <key>IBFramework Version</key>
<string>439.0</string> <string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key> <key>IBOpenObjects</key>
<array> <array/>
<integer>29</integer>
</array>
<key>IBSystem Version</key> <key>IBSystem Version</key>
<string>8R218</string> <string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict> </dict>
</plist> </plist>

BIN
Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib generated
View File

Binary file not shown.

49
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib generated
View File

@ -1,17 +1,32 @@
{ <?xml version="1.0" encoding="UTF-8"?>
IBClasses = ( <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
{ <plist version="1.0">
ACTIONS = { <dict>
newFactorWorkspace = id; <key>IBClasses</key>
runFactorFile = id; <array>
saveFactorImage = id; <dict>
saveFactorImageAs = id; <key>ACTIONS</key>
showFactorHelp = id; <dict>
}; <key>newFactorWorkspace</key>
CLASS = FirstResponder; <string>id</string>
LANGUAGE = ObjC; <key>runFactorFile</key>
SUPERCLASS = NSObject; <string>id</string>
} <key>saveFactorImage</key>
); <string>id</string>
IBVersion = 1; <key>saveFactorImageAs</key>
} <string>id</string>
<key>showFactorHelp</key>
<string>id</string>
</dict>
<key>CLASS</key>
<string>FirstResponder</string>
<key>LANGUAGE</key>
<string>ObjC</string>
<key>SUPERCLASS</key>
<string>NSObject</string>
</dict>
</array>
<key>IBVersion</key>
<string>1</string>
</dict>
</plist>

19
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib generated
View File

@ -1,21 +1,18 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0"> <plist version="1.0">
<dict> <dict>
<key>IBDocumentLocation</key>
<string>1266 155 525 491 0 0 2560 1578 </string>
<key>IBEditorPositions</key>
<dict>
<key>29</key>
<string>326 905 270 44 0 0 2560 1578 </string>
</dict>
<key>IBFramework Version</key> <key>IBFramework Version</key>
<string>439.0</string> <string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key> <key>IBOpenObjects</key>
<array> <array>
<integer>29</integer> <integer>293</integer>
</array> </array>
<key>IBSystem Version</key> <key>IBSystem Version</key>
<string>8R218</string> <string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict> </dict>
</plist> </plist>

BIN
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib generated
View File

Binary file not shown.

225
GNUmakefile Executable file
View File

@ -0,0 +1,225 @@
ifdef CONFIG
CC = gcc
CPP = g++
AR = ar
LD = ld
VERSION = 0.92
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall $(SITE_CFLAGS)
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
else
CFLAGS += -O3
endif
include $(CONFIG)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callbacks.o \
vm/callstack.o \
vm/code_blocks.o \
vm/code_heap.o \
vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/data_heap_checker.o \
vm/debug.o \
vm/dispatch.o \
vm/entry_points.o \
vm/errors.o \
vm/factor.o \
vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
vm/image.o \
vm/inline_cache.o \
vm/instruction_operands.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
vm/strings.o \
vm/to_tenured_collector.o \
vm/tuples.o \
vm/utilities.o \
vm/vm.o \
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS)
FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
TEST_OBJS = vm/ffi_test.o
endif
default:
$(MAKE) `./build-support/factor.sh make-target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
@echo "linux-ppc"
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "netbsd-x86-32"
@echo "netbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@echo "DEBUG=1 compile VM with debugging information"
@echo "SITE_CFLAGS=... additional optimization flags"
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
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/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
$(FFI_TEST_LIBRARY): vm/ffi_test.o
$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o $(FFI_TEST_LIBRARY) $(TEST_OBJS)
vm/resources.o:
$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.cpp.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.SUFFIXES: .mm
endif
clean:
rm -f vm/*.o
rm -f factor.dll
rm -f factor.lib
rm -f factor.dll.lib
rm -f libfactor.*
rm -f libfactor-ffi-test.*
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
tags:
etags vm/*.{cpp,hpp,mm,S,c}
.PHONY: factor factor-console factor-ffi-test tags clean macosx.app

156
Makefile
View File

@ -1,156 +0,0 @@
CC = gcc
AR = ar
LD = ld
EXECUTABLE = factor
VERSION = 0.91
IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g
else
CFLAGS += -O3 $(SITE_CFLAGS)
endif
ifdef CONFIG
include $(CONFIG)
endif
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/code_heap.o \
vm/debug.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
vm/data_gc.o \
vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/callstack.o \
vm/types.o \
vm/quotations.o \
vm/utilities.o \
vm/errors.o \
vm/profiler.o
EXE_OBJS = $(PLAF_EXE_OBJS)
default:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
@echo "linux-ppc"
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "windows-ce-arm"
@echo "windows-nt-x86-32"
@echo ""
@echo "Additional modifiers:"
@echo ""
@echo "DEBUG=1 compile VM with debugging information"
@echo "SITE_CFLAGS=... additional optimization flags"
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@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
openbsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
macosx-freetype:
ln -sf libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.dylib
macosx-ppc: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.ppc
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
linux-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
windows-nt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
windows-ce-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
install_name_tool \
-id @executable_path/../Frameworks/libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.6.dylib
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
factor: $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
clean:
rm -f vm/*.o
vm/resources.o:
windres vm/factor.rs vm/resources.o
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
.S.o:
$(CC) -c $(CFLAGS) -o $@ $<
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
.PHONY: factor

88
Nmakefile Executable file
View File

@ -0,0 +1,88 @@
!IF DEFINED(DEBUG)
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3
!ENDIF
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \
vm\aging_collector.obj \
vm\alien.obj \
vm\arrays.obj \
vm\bignum.obj \
vm\booleans.obj \
vm\byte_arrays.obj \
vm\callbacks.obj \
vm\callstack.obj \
vm\code_blocks.obj \
vm\code_heap.obj \
vm\compaction.obj \
vm\contexts.obj \
vm\data_heap.obj \
vm\data_heap_checker.obj \
vm\debug.obj \
vm\dispatch.obj \
vm\entry_points.obj \
vm\errors.obj \
vm\factor.obj \
vm\free_list.obj \
vm\full_collector.obj \
vm\gc.obj \
vm\image.obj \
vm\inline_cache.obj \
vm\instruction_operands.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
vm\primitives.obj \
vm\profiler.obj \
vm\quotations.obj \
vm\run.obj \
vm\strings.obj \
vm\to_tenured_collector.obj \
vm\tuples.obj \
vm\utilities.obj \
vm\vm.obj \
vm\words.obj
.cpp.obj:
cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
.c.obj:
cl $(CL_FLAGS) /Fo$@ /c $<
.rs.res:
rc $<
all: factor.com factor.exe libfactor-ffi-test.dll
libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
clean:
del vm\*.obj
del factor.lib
del factor.com
del factor.exe
del factor.dll
del factor.dll.lib
.PHONY: all clean
.SUFFIXES: .rs

184
README.txt
View File

@ -1,184 +0,0 @@
The Factor programming language
-------------------------------
This file covers installation and basic usage of the Factor
implementation. It is not an introduction to the language itself.
* Contents
- Platform support
- Compiling the Factor VM
- Bootstrapping the Factor image
- Running Factor on Unix with X11
- Running Factor on Mac OS X - Cocoa UI
- Running Factor on Mac OS X - X11 UI
- Running Factor on Windows
- Command line usage
- Source organization
- Community
* Platform support
Factor supports the following platforms:
Linux/x86
Linux/AMD64
Linux/PowerPC
Linux/ARM
Mac OS X/x86
Mac OS X/PowerPC
FreeBSD/x86
FreeBSD/AMD64
OpenBSD/x86
OpenBSD/AMD64
Solaris/x86
Solaris/AMD64
MS Windows/x86 (XP and above)
MS Windows CE/ARM
Please donate time or hardware if you wish to see Factor running on
other platforms. In particular, we are interested in:
Windows/AMD64
Mac OS X/AMD64
Solaris/UltraSPARC
Linux/MIPS
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
3.3 or earlier.
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
targets and build options. Then run 'make' with the appropriate target
for your platform.
Compilation will yield an executable named 'factor' on Unix,
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Bootstrapping the Factor image
The boot images are no longer included with the Factor distribution
due to size concerns. Instead, download a boot image from:
http://factorcode.org/images/
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Once you download the right image, bootstrap the system with the
following command line:
./factor -i=boot.<cpu>.image
Or this command for Mac OS X systems:
./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
machines.
* Running Factor on Unix with X11
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
If your DISPLAY environment variable is set, the UI will start
automatically:
./factor
To run an interactive terminal listener:
./factor -run=listener
If you're inside a terminal session, you can start the UI with one of
the following two commands:
ui
[ ui ] in-thread
The latter keeps the terminal listener running.
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
terminal listener. If you are using Mac OS X 10.3, you can only run the
X11 UI, as documented in the next section.
The 'factor' executable runs the terminal listener:
./factor
The 'Factor.app' bundle runs the Cocoa UI. Note that this is not a
self-contained bundle, it must be run from the same directory which
contains factor.image and the library sources.
* Running Factor on Mac OS X - X11 UI
The X11 UI is available on Mac OS X, however its use is not recommended
since it does not integrate with the host OS. However, if you are
running Mac OS X 10.3, it is your only choice.
When compiling Factor, pass the X11=1 parameter:
make macosx-ppc X11=1
Then bootstrap with the following switches:
./factor -i=boot.ppc.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
* Running Factor on Windows XP/Vista
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
factor-nt.exe -i=boot.x86.32.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt:
factor-nt.exe -run=listener
* Command line usage
The Factor VM supports a number of command line switches. To read
command line usage documentation, either enter the following in the UI
listener:
"command-line" about
* Source organization
The following two directories are managed by the module system; consult
the documentation for details:
core/ - Factor core library and compiler
extra/ - more libraries
The following directories contain additional files:
misc/ - editor modes, icons, etc
vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI
unmaintained/ - unmaintained contributions, please help!
* Community
The Factor homepage is located at <http://factorcode.org/>.
Factor developers meet in the #concatenative channel on the
irc.freenode.net server. Drop by if you want to discuss anything related
to Factor or language design in general.
Have fun!
:tabSize=2:indentSize=2:noTabs=true:

69
basis/alarms/alarms-docs.factor Normal file
View File

@ -0,0 +1,69 @@
USING: help.markup help.syntax calendar quotations system ;
IN: alarms
HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
HELP: current-alarm
{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
}
{ $examples
{ $unchecked-example
"""USING: alarms calendar io threads ;"""
"""["""
""" "Hi, this should only get printed once..." print flush"""
""" current-alarm get cancel-alarm"""
"""] 1 seconds every"""
""
}
} ;
HELP: add-alarm
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
HELP: later
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes drop"""
""
}
} ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
HELP: every
{ $values
{ "quot" quotation } { "duration" duration }
{ "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
""
}
} ;
ARTICLE: "alarms" "Alarms"
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $nl
"The alarm class:"
{ $subsections alarm }
"Register a recurring alarm:"
{ $subsections every }
"Register a one-time alarm:"
{ $subsections later }
"The currently executing alarm:"
{ $subsections current-alarm }
"Low-level interface to add alarms:"
{ $subsections add-alarm }
"Cancelling an alarm:"
{ $subsections cancel-alarm }
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
ABOUT: "alarms"

17
basis/alarms/alarms-tests.factor Normal file
View File

@ -0,0 +1,17 @@
USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ;
IN: alarms.tests
[ ] [
1 <count-down>
{ f } clone 2dup
[ first cancel-alarm count-down ] 2curry 1 seconds later
swap set-first
await
] unit-test
[ ] [
[
[ resume ] curry instant later drop
] "test" suspend drop
] unit-test

104
basis/alarms/alarms.factor Normal file
View File

@ -0,0 +1,104 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar combinators.short-circuit
continuations fry heaps init kernel math.order
namespaces quotations threads math system ;
IN: alarms
TUPLE: alarm
{ quot callable initial: [ ] }
{ start integer }
interval
{ entry box } ;
SYMBOL: alarms
SYMBOL: alarm-thread
SYMBOL: current-alarm
: cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ;
<PRIVATE
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
GENERIC: >nanoseconds ( obj -- duration/f )
M: f >nanoseconds ;
M: real >nanoseconds >integer ;
M: duration >nanoseconds duration>nanoseconds >integer ;
: <alarm> ( quot start interval -- alarm )
alarm new
swap >nanoseconds >>interval
swap >nanoseconds nano-count + >>start
swap >>quot
<box> >>entry ;
: register-alarm ( alarm -- )
[ dup start>> alarms get-global heap-push* ]
[ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm n -- ? )
[ start>> ] dip <= ;
: reschedule-alarm ( alarm -- )
dup interval>> nano-count + >>start register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
[ dup interval>> [ reschedule-alarm ] [ drop ] if ]
[
[ ] [ quot>> ] [ ] tri
'[
_ current-alarm
[
_ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ]
recover
] with-variable
] "Alarm execution" spawn drop
] tri ;
: (trigger-alarms) ( alarms n -- )
over heap-empty? [
2drop
] [
over heap-peek drop over alarm-expired? [
over heap-pop drop call-alarm (trigger-alarms)
] [
2drop
] if
] if ;
: trigger-alarms ( alarms -- )
nano-count (trigger-alarms) ;
: next-alarm ( alarms -- nanos/f )
dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
: alarm-thread-loop ( -- )
alarms get-global
dup next-alarm sleep-until
trigger-alarms ;
: cancel-alarms ( alarms -- )
[
heap-pop-all [ nip entry>> box> drop ] assoc-each
] when* ;
: init-alarms ( -- )
alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;
[ init-alarms ] "alarms" add-startup-hook
PRIVATE>
: add-alarm ( quot start interval -- alarm )
<alarm> [ register-alarm ] keep ;
: later ( quot duration -- alarm ) f add-alarm ;
: every ( quot duration -- alarm ) dup add-alarm ;

0
extra/base64/authors.txt → basis/alarms/authors.txt Normal file → Executable file
View File

1
basis/alarms/summary.txt Normal file
View File

@ -0,0 +1 @@
One-time and recurring events

106
basis/alien/arrays/arrays.factor Normal file
View File

@ -0,0 +1,106 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.data alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
IN: alien.arrays
INSTANCE: array value-type
M: array c-type ;
M: array c-type-class drop object ;
M: array c-type-boxed-class drop object ;
: array-length ( seq -- n )
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
M: array c-type-align-first first c-type-align-first ;
M: array c-type-stack-align? drop f ;
M: array unbox-parameter drop void* unbox-parameter ;
M: array unbox-return drop void* unbox-return ;
M: array box-parameter drop void* box-parameter ;
M: array box-return drop void* box-return ;
M: array stack-size drop void* stack-size ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
PREDICATE: string-type < pair
first2 [ char* = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-class drop object ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop void* heap-size ;
M: string-type c-type-align
drop void* c-type-align ;
M: string-type c-type-align-first
drop void* c-type-align-first ;
M: string-type c-type-stack-align?
drop void* c-type-stack-align? ;
M: string-type unbox-parameter
drop void* unbox-parameter ;
M: string-type unbox-return
drop void* unbox-return ;
M: string-type box-parameter
drop void* box-parameter ;
M: string-type box-return
drop void* box-return ;
M: string-type stack-size
drop void* stack-size ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
drop void* c-type-boxer ;
M: string-type c-type-unboxer
drop void* c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ char* utf8 } char* typedef
char* uchar* typedef
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

0
core/alien/arrays/authors.txt → basis/alien/arrays/authors.txt
View File

0
core/alien/arrays/summary.txt → basis/alien/arrays/summary.txt
View File

0
core/alien/c-types/authors.txt → basis/alien/c-types/authors.txt
View File

252
basis/alien/c-types/c-types-docs.factor Normal file
View File

@ -0,0 +1,252 @@
USING: alien alien.complex help.syntax help.markup libc kernel.private
byte-arrays strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
QUALIFIED: math
QUALIFIED: sequences
IN: alien.c-types
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
HELP: heap-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
{ $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
{ $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
HELP: no-c-type
{ $values { "name" "a C type name" } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
HELP: c-types
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
HELP: c-type
{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-getter
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: box-parameter
{ $values { "n" math:integer } { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: box-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
HELP: unbox-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: define-deref
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-out
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: char
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: uchar
{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: short
{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: ushort
{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: int
{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: uint
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: long
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: intptr_t
{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulong
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: uintptr_t
{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ptrdiff_t
{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: size_t
{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
HELP: longlong
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulonglong
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: void
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
HELP: float
{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
HELP: double
{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
HELP: complex-float
{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
HELP: complex-double
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
$nl
"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
{ $list
"the C function returns"
"the C function calls Factor code via a callback"
}
"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
$nl
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
ARTICLE: "c-out-params" "Output parameters in C"
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
$nl
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
{ $subsections
<char>
<uchar>
<short>
<ushort>
<int>
<uint>
<long>
<ulong>
<longlong>
<ulonglong>
<float>
<double>
<void*>
}
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
{ $subsections
*char
*uchar
*short
*ushort
*int
*uint
*long
*ulong
*longlong
*ulonglong
*float
*double
*void*
}
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types.primitives" "Primitive C types"
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
{ $table
{ "C type" "Notes" }
{ { $link char } "always 1 byte" }
{ { $link uchar } { } }
{ { $link short } "always 2 bytes" }
{ { $link ushort } { } }
{ { $link int } "always 4 bytes" }
{ { $link uint } { } }
{ { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
{ { $link ulong } { } }
{ { $link longlong } "always 8 bytes" }
{ { $link ulonglong } { } }
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
}
"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
{ $table
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
}
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
ARTICLE: "c-types.pointers" "Pointer and array types"
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
$nl
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
"Note that some of the C type word names clash with commonly-used Factor words:"
{ $list
{ { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
{ { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
}
"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
{ $code
"USING: alien.syntax math prettyprint ;"
"FUNCTION: float magic_number ( ) ;"
"magic_number 3.0 + ."
}
"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
{ $code
"USING: alien.c-types alien.syntax math prettyprint ;"
"FUNCTION: float magic_number ( ) ;"
"magic_number 3.0 + ."
}
"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
{ $code
"USING: alien.syntax math prettyprint ;"
"QUALIFIED-WITH: alien.c-types c"
"FUNCTION: c:float magic_number ( ) ;"
"magic_number 3.0 + ."
}
"See " { $link "word-search-semantics" } " for details." ;
ARTICLE: "c-types.structs" "Struct and union types"
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
ARTICLE: "c-types-specs" "C type specifiers"
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
$nl
"Defining new C types:"
{ $subsections
POSTPONE: STRUCT:
POSTPONE: UNION-STRUCT:
POSTPONE: CALLBACK:
POSTPONE: TYPEDEF:
}
{ $heading "Related articles" }
{ $subsections
"c-types.primitives"
"c-types.pointers"
"c-types.ambiguity"
"c-types.structs"
}
;
ABOUT: "c-types-specs"

112
basis/alien/c-types/c-types-tests.factor Normal file
View File

@ -0,0 +1,112 @@
USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
IN: alien.c-types.tests
CONSTANT: xyz 123
[ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
[ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: int* MyIntArray
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] must-fail
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
] when
[ 0 ] [ -10 uchar c-type-clamp ] unit-test
[ 12 ] [ 12 uchar c-type-clamp ] unit-test
[ -10 ] [ -10 char c-type-clamp ] unit-test
[ 127 ] [ 230 char c-type-clamp ] unit-test
[ t ] [ pi dup float c-type-clamp = ] unit-test
C-TYPE: opaque
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
[ opaque c-type ] [ no-c-type? ] must-fail-with
[ """
USING: alien.syntax ;
IN: alien.c-types.tests
FUNCTION: opaque return_opaque ( ) ;
""" eval( -- ) ] [ no-c-type? ] must-fail-with
C-TYPE: forward
STRUCT: backward { x forward* } ;
STRUCT: forward { x backward* } ;
[ t ] [ forward c-type struct-c-type? ] unit-test
[ t ] [ backward c-type struct-c-type? ] unit-test
DEFER: struct-redefined
[ f ]
[
"""
USING: alien.c-types classes.struct ;
IN: alien.c-types.tests
STRUCT: struct-redefined { x int } ;
""" eval( -- )
"""
USING: alien.syntax ;
IN: alien.c-types.tests
C-TYPE: struct-redefined
""" eval( -- )
\ struct-redefined class?
] unit-test
[
"IN: alien.c-types.tests
USE: alien.syntax
USE: alien.c-types
TYPEDEF: int type-redefinition-test
TYPEDEF: int type-redefinition-test" eval( -- )
]
[ error>> error>> redefine-error? ]
must-fail-with

571
basis/alien/c-types/c-types.factor Normal file
View File

@ -0,0 +1,571 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private math
math.order math.parser namespaces make parser sequences strings
words splitting cpu.architecture alien alien.accessors
alien.strings quotations layouts system compiler.units io
io.files io.encodings.binary io.streams.memory accessors
combinators effects continuations fry classes vocabs
vocabs.loader words.symbol ;
QUALIFIED: math
IN: alien.c-types
SYMBOLS:
char uchar
short ushort
int uint
long ulong
longlong ulonglong
float double
void* bool
void ;
DEFER: <int>
DEFER: *char
TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
{ size integer }
{ align integer }
{ align-first integer } ;
TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align? ;
: <c-type> ( -- c-type )
\ c-type new ; inline
SYMBOL: c-types
global [
c-types [ H{ } assoc-like ] change
] bind
ERROR: no-c-type name ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
UNION: c-type-name string c-type-word ;
! C type protocol
GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
<< \ void \ void* "pointer-c-type" set-word-prop >>
: void? ( c-type -- ? )
{ void "void" } member? ;
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
drop
c-types get at dup c-type-name?
[ resolve-pointer-type ] [ drop void* ] if
] if ;
M: array resolve-pointer-type
first resolve-pointer-type ;
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
<PRIVATE
: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop string>number ] map ] dip ;
PRIVATE>
M: string c-type ( name -- c-type )
CHAR: ] over member? [
parse-array-type prefix
] [
dup c-types get at [ ] [
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
] ?if resolve-typedef
] if ;
M: word c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
GENERIC: c-struct? ( c-type -- ? )
M: object c-struct? drop f ;
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: c-type-name c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
M: c-type-name c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
M: c-type-name c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
M: c-type-name c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
M: c-type-name c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
M: c-type-name c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: abstract-c-type c-type-align align>> ;
M: c-type-name c-type-align c-type c-type-align ;
GENERIC: c-type-align-first ( name -- n )
M: c-type-name c-type-align-first c-type c-type-align-first ;
M: abstract-c-type c-type-align-first align-first>> ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n c-type -- )
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
M: c-type-name box-parameter c-type box-parameter ;
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
M: c-type-name box-return c-type box-return ;
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
M: c-type-name unbox-return c-type unbox-return ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size )
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
M: c-type-name stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
MIXIN: value-type
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
] unless* ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: array-accessor ( c-type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
GENERIC: typedef ( old new -- )
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
M: string typedef ( old new -- ) c-types get set-at ;
M: word typedef ( old new -- )
{
[ nip define-symbol ]
[ name>> typedef ]
[ swap "c-type" set-word-prop ]
[
swap dup c-type-name? [
resolve-pointer-type
"pointer-c-type" set-word-prop
] [ 2drop ] if
]
} 2cleave ;
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- c-type )
long-long-type new ;
M: long-long-type unbox-parameter ( n c-type -- )
c-type-unboxer %unbox-long-long ;
M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
M: long-long-type box-parameter ( n c-type -- )
c-type-boxer %box-long-long ;
M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
: define-deref ( c-type -- )
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
: define-out ( c-type -- )
[ name>> "alien.c-types" constructor-word ]
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
[ typedef ] [ define-deref ] [ define-out ] tri ;
: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
CONSTANT: primitive-types
{
char uchar
short ushort
int uint
long ulong
longlong ulonglong
float double
void* bool
}
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
: 8-byte-alignment ( c-type -- c-type )
{
{ [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
{ [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
[ 8 >>align 8 >>align-first ]
} cond ;
[
<c-type>
c-ptr >>class
c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
[ >c-ptr ] >>unboxer-quot
"allot_alien" >>boxer
"alien_offset" >>unboxer
\ void* define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
2 >>align-first
"from_signed_2" >>boxer
"to_fixnum" >>unboxer
\ short define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
2 >>align-first
"from_unsigned_2" >>boxer
"to_cell" >>unboxer
\ ushort define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
1 >>align-first
"from_signed_1" >>boxer
"to_fixnum" >>unboxer
\ char define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
1 >>align-first
"from_unsigned_1" >>boxer
"to_cell" >>unboxer
\ uchar define-primitive-type
cpu ppc? [
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] [
<c-type>
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
1 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] if
\ bool define-primitive-type
<c-type>
math:float >>class
math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_float" >>boxer
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
\ float define-primitive-type
<c-type>
math:float >>class
math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8-byte-alignment
"from_double" >>boxer
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
\ double define-primitive-type
cell 8 = [
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ longlong define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ ulonglong define-primitive-type
os windows? [
\ int c-type \ long define-primitive-type
\ uint c-type \ ulong define-primitive-type
] [
\ longlong c-type \ long define-primitive-type
\ ulonglong c-type \ ulong define-primitive-type
] if
\ longlong c-type \ ptrdiff_t typedef
\ longlong c-type \ intptr_t typedef
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
8-byte-alignment
"from_signed_8" >>boxer
"to_signed_8" >>unboxer
\ longlong define-primitive-type
<long-long-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
8-byte-alignment
"from_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
\ ulonglong define-primitive-type
\ int c-type \ long define-primitive-type
\ uint c-type \ ulong define-primitive-type
\ int c-type \ ptrdiff_t typedef
\ int c-type \ intptr_t typedef
\ uint c-type \ uintptr_t typedef
\ uint c-type \ size_t typedef
] if
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;
M: uchar-16-rep rep-component-type drop uchar ;
M: short-8-rep rep-component-type drop short ;
M: ushort-8-rep rep-component-type drop ushort ;
M: int-4-rep rep-component-type drop int ;
M: uint-4-rep rep-component-type drop uint ;
M: longlong-2-rep rep-component-type drop longlong ;
M: ulonglong-2-rep rep-component-type drop ulonglong ;
M: float-4-rep rep-component-type drop float ;
M: double-2-rep rep-component-type drop double ;
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
: c-type-interval ( c-type -- from to )
{
{ [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
{ [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
{ [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
} cond ; foldable
: c-type-clamp ( value c-type -- value' )
dup { float double } member-eq?
[ drop ] [ c-type-interval clamp ] if ; inline

0
core/alien/c-types/summary.txt → basis/alien/c-types/summary.txt
View File

1
basis/alien/complex/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

21
basis/alien/complex/complex-tests.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 tools.test alien.complex classes.struct kernel
alien.c-types alien.syntax namespaces math ;
IN: alien.complex.tests
STRUCT: complex-holder
{ z complex-float } ;
: <complex-holder> ( z -- alien )
complex-holder <struct-boa> ;
[ ] [
C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test

13
basis/alien/complex/complex.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.complex.functor accessors
sequences kernel ;
IN: alien.complex
<<
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
>>

1
basis/alien/complex/functor/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

31
basis/alien/complex/functor/functor.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types classes.struct math
math.functions sequences arrays kernel functors vocabs.parser
namespaces quotations ;
IN: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- )
T-class DEFINES-CLASS ${T}
<T> DEFINES <${T}>
*T DEFINES *${T}
WHERE
STRUCT: T-class { real N } { imaginary N } ;
: <T> ( z -- alien )
>rect T-class <struct-boa> >c-ptr ;
: *T ( alien -- z )
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
T-class c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
complex >>boxed-class
drop
;FUNCTOR

1
basis/alien/complex/functor/summary.txt Normal file
View File

@ -0,0 +1 @@
Code generation for C99 complex number support

1
basis/alien/complex/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation details for C99 complex float and complex double types

0
core/alien/compiler/authors.txt → basis/alien/data/authors.txt
View File

161
basis/alien/data/data-docs.factor Normal file
View File

@ -0,0 +1,161 @@
USING: alien alien.c-types help.syntax help.markup libc
kernel.private byte-arrays math strings hashtables alien.syntax
alien.strings sequences io.encodings.string debugger destructors
vocabs.loader classes.struct ;
IN: alien.data
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array suitable for holding a value with the given C type." }
{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
{ <c-object> malloc-object } related-words
HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
HELP: byte-array>memory
{ $values { "byte-array" byte-array } { "base" c-ptr } }
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
HELP: malloc-object
{ $values { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
HELP: malloc-byte-array
{ $values { "byte-array" byte-array } { "alien" alien } }
{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
{ <c-array> <c-direct-array> malloc-array } related-words
{ string>alien alien>string malloc-string } related-words
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsections
malloc-object
malloc-byte-array
}
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
{ $subsections
malloc
calloc
realloc
}
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsections free }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsections
&free
|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:"
{ $subsections memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsections memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsections byte-array>memory } ;
ARTICLE: "c-pointers" "Passing pointers to C functions"
"The following Factor objects may be passed to C function parameters with pointer types:"
{ $list
{ "Instances of " { $link alien } "." }
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
{ "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
}
"The class of primitive C pointer types:"
{ $subsections c-ptr }
"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:"
{ $subsections >c-ptr }
"More about the " { $link alien } " type:"
{ $subsections "aliens" }
{ $warning
"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsections
"c-types-specs"
"c-pointers"
"malloc"
"c-strings"
"c-out-params"
}
"Important guidelines for passing data in byte arrays:"
{ $subsections "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsections POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsections POSTPONE: TYPEDEF: }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsections "alien.destructors" }
"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: require-c-array
{ $values { "c-type" "a C type" } }
{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsections
string>alien
malloc-string
}
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsections alien>string }
"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;

75
basis/alien/data/data.factor Normal file
View File

@ -0,0 +1,75 @@
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
M: array require-c-array first require-c-array ;
GENERIC: c-array-constructor ( c-type -- word ) foldable
GENERIC: c-(array)-constructor ( c-type -- word ) foldable
GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
GENERIC: <c-array> ( len c-type -- array )
M: word <c-array>
c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
M: word (c-array)
c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
M: word <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
: malloc-array ( n type -- array )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
: <c-object> ( type -- array )
heap-size <byte-array> ; inline
: (c-object) ( type -- array )
heap-size (byte-array) ; inline
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
: (malloc-object) ( type -- alien )
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;

1
basis/alien/data/summary.txt Normal file
View File

@ -0,0 +1 @@
Words for allocating objects and arrays of C types

1
basis/alien/destructors/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

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."
{ $subsections POSTPONE: DESTRUCTOR: } ;
ABOUT: "alien.destructors"

32
basis/alien/destructors/destructors.factor Normal file
View File

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

1
basis/alien/destructors/summary.txt Normal file
View File

@ -0,0 +1 @@
Functor for defining destructors which call a C function to dispose of resources

1
basis/alien/fortran/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

69
basis/alien/fortran/fortran-docs.factor Normal file
View File

@ -0,0 +1,69 @@
! Copyright (C) 2009 Joe Groff
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ;
QUALIFIED-WITH: alien.syntax c
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
{ { $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." ;
ARTICLE: "alien.fortran-types" "Fortran types"
"The Fortran FFI recognizes the following Fortran types:"
{ $list
{ { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
{ { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
{ { $snippet "REAL" } " specifies a single-precision floating-point real value." }
{ { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
{ { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
{ "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." }
}
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
HELP: FUNCTION:
{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
HELP: SUBROUTINE:
{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
HELP: LIBRARY:
{ $syntax "LIBRARY: name" }
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
HELP: add-fortran-library
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
;
HELP: fortran-invoke
{ $values
{ "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
}
{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
;
ARTICLE: "alien.fortran" "Fortran FFI"
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
{ $subsections
"alien.fortran-types"
"alien.fortran-abis"
add-fortran-library
POSTPONE: LIBRARY:
POSTPONE: FUNCTION:
POSTPONE: SUBROUTINE:
fortran-invoke
} ;
ABOUT: "alien.fortran"

374
basis/alien/fortran/fortran-tests.factor Normal file
View File

@ -0,0 +1,374 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex
alien.data alien.fortran alien.fortran.private alien.strings
classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran.tests
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
STRUCT: fortran_test_record
{ FOO int }
{ BAR double[2] }
{ BAS char[4] } ;
intel-unix-abi fortran-abi [
! fortran-name>symbol-name
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
[ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
[ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
! fortran-type>c-type
[ c:short ]
[ "integer*2" fortran-type>c-type ] unit-test
[ c:int ]
[ "integer*4" fortran-type>c-type ] unit-test
[ c:int ]
[ "INTEGER" fortran-type>c-type ] unit-test
[ c:longlong ]
[ "iNteger*8" fortran-type>c-type ] unit-test
[ { c:int 0 } ]
[ "integer(*)" fortran-type>c-type ] unit-test
[ { c:int 0 } ]
[ "integer(3,*)" fortran-type>c-type ] unit-test
[ { c:int 3 } ]
[ "integer(3)" fortran-type>c-type ] unit-test
[ { c:int 6 } ]
[ "integer(3,2)" fortran-type>c-type ] unit-test
[ { c:int 24 } ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
[ c:char ]
[ "character" fortran-type>c-type ] unit-test
[ c:char ]
[ "character*1" fortran-type>c-type ] unit-test
[ { c:char 17 } ]
[ "character*17" fortran-type>c-type ] unit-test
[ { c:char 17 } ]
[ "character(17)" fortran-type>c-type ] unit-test
[ c:int ]
[ "logical" fortran-type>c-type ] unit-test
[ c:float ]
[ "real" fortran-type>c-type ] unit-test
[ c:double ]
[ "double-precision" fortran-type>c-type ] unit-test
[ c:float ]
[ "real*4" fortran-type>c-type ] unit-test
[ c:double ]
[ "real*8" fortran-type>c-type ] unit-test
[ complex-float ]
[ "complex" fortran-type>c-type ] unit-test
[ complex-double ]
[ "double-complex" fortran-type>c-type ] unit-test
[ complex-float ]
[ "complex*8" fortran-type>c-type ] unit-test
[ complex-double ]
[ "complex*16" fortran-type>c-type ] unit-test
[ fortran_test_record ]
[
[
"alien.fortran.tests" use-vocab
"fortran_test_record" fortran-type>c-type
] with-manifest
] unit-test
! fortran-arg-type>c-type
[ c:void* { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[
[
"alien.fortran.tests" use-vocab
"fortran_test_record" fortran-arg-type>c-type
] with-manifest
] unit-test
[ c:char* { } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:char* { } ]
[ "character(1)" fortran-arg-type>c-type ] unit-test
[ c:char* { long } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
! fortran-ret-type>c-type
[ c:char { } ]
[ "character(1)" fortran-ret-type>c-type ] unit-test
[ c:void { c:char* long } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
[ c:int { } ]
[ "integer" fortran-ret-type>c-type ] unit-test
[ c:int { } ]
[ "logical" fortran-ret-type>c-type ] unit-test
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[
[
"alien.fortran.tests" use-vocab
"fortran_test_record" fortran-ret-type>c-type
] with-manifest
] unit-test
! fortran-sig>c-sig
[ c:float { c:void* c:char* c:void* c:void* c:long } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ c:char { c:char* c:char* c:void* c:long } ]
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:void* c:char* c:char* c:void* c:long } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
! (fortran-invoke)
[ [
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <longlong> ]
[ <float> ]
[ <complex-float> ]
[ 1 0 ? <short> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
! [fortran-invoke]
[
c:void "funpack" "funtimes_"
{ c:char* c:void* c:void* c:void* c:void* c:long }
alien-invoke
] 6 nkeep
! [fortran-results>]
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
{
[ drop ]
[ drop ]
[ drop ]
[ *float ]
[ drop ]
[ drop ]
} spread
] ] [
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
(fortran-invoke)
] unit-test
[ [
! [fortran-args>c-args]
{
[ { [ ] } spread ]
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ ] [ drop ] } spread
] ] [
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ complex-float <c-object> ] 1 ndip
! [fortran-args>c-args]
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ void* void* }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ *complex-float ] [ drop ] } spread
] ] [
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta retb -- reta retb )
{ [ ] [ ascii alien>nstring ] } spread
] ] [
"CHARACTER*20" "funpack" "FUN_TIMES" { }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 10 <byte-array> 10 ] 3 ndip
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <float> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
} 3 ncleave
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long c:char* c:void* c:char* c:long c:long }
alien-invoke
] 7 nkeep
! [fortran-results>]
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
{
[ ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
[ *float ]
[ ]
[ ascii alien>nstring ]
} spread
] ] [
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
(fortran-invoke)
] unit-test
] with-variable ! intel-unix-abi
intel-windows-abi fortran-abi [
[ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
[ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
[ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
] with-variable
f2c-abi fortran-abi [
[ { c:char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
] with-variable
gfortran-abi fortran-abi [
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ { char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
] with-variable

448
basis/alien/fortran/fortran.factor Normal file
View File

@ -0,0 +1,448 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.data alien.parser
grouping alien.strings alien.syntax arrays ascii assocs
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 alien.libraries ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran
SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
"I77" "libI77.so" "cdecl" add-library
"F77" "libF77.so" "cdecl" add-library ;
os netbsd? [ add-f2c-libraries ] when
>>
: alien>nstring ( alien len encoding -- string )
[ memory>byte-array ] dip decode ;
ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
DEFER: fortran-name>symbol-name
SYMBOL: library-fortran-abis
SYMBOL: fortran-abi
library-fortran-abis [ H{ } clone ] initialize
<PRIVATE
: lowercase-name-with-underscore ( name -- name' )
>lower "_" append ;
: lowercase-name-with-extra-underscore ( name -- name' )
>lower CHAR: _ over member?
[ "__" append ] [ "_" append ] if ;
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 ;
TUPLE: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ;
TUPLE: logical-type < integer-type ;
TUPLE: real-type < number-type ;
TUPLE: double-precision-type < number-type ;
TUPLE: character-type < fortran-type ;
TUPLE: misc-type < fortran-type name ;
TUPLE: complex-type < number-type ;
TUPLE: real-complex-type < complex-type ;
TUPLE: double-complex-type < complex-type ;
CONSTANT: fortran>c-types H{
{ "character" character-type }
{ "integer" integer-type }
{ "logical" logical-type }
{ "real" real-type }
{ "double-precision" double-precision-type }
{ "complex" real-complex-type }
{ "double-complex" double-complex-type }
}
: append-dimensions ( base-c-type type -- c-type )
dims>> [ product 2array ] when* ;
MACRO: size-case-type ( cases -- )
[ invalid-fortran-type ] suffix
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
: simple-type ( type base-c-type -- c-type )
swap
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
[ append-dimensions ] bi ;
: new-fortran-type ( out? dims size class -- type )
new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type )
M: f (fortran-type>c-type) drop c:void ;
M: integer-type (fortran-type>c-type)
{
{ f [ c:int ] }
{ 1 [ c:char ] }
{ 2 [ c:short ] }
{ 4 [ c:int ] }
{ 8 [ c:longlong ] }
} size-case-type ;
M: real-type (fortran-type>c-type)
{
{ f [ c:float ] }
{ 4 [ c:float ] }
{ 8 [ c:double ] }
} size-case-type ;
M: real-complex-type (fortran-type>c-type)
{
{ f [ complex-float ] }
{ 8 [ complex-float ] }
{ 16 [ complex-double ] }
} size-case-type ;
M: double-precision-type (fortran-type>c-type)
c:double simple-type ;
M: double-complex-type (fortran-type>c-type)
complex-double simple-type ;
M: misc-type (fortran-type>c-type)
dup name>> parse-c-type simple-type ;
: single-char? ( character-type -- ? )
{ [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
: fix-character-type ( character-type -- character-type' )
clone dup size>>
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
[ dup dims>> [ ] [ f >>dims ] if ] if
dup single-char? [ f >>dims ] when ;
M: character-type (fortran-type>c-type)
fix-character-type c:char simple-type ;
: dimension>number ( string -- number )
dup "*" = [ drop 0 ] [ string>number ] if ;
: parse-out ( string -- string' out? )
"!" ?head ;
: parse-dims ( string -- string' dim )
"(" split1 dup
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
: parse-size ( string -- string' size )
"*" split1 dup [ string>number ] when ;
: (parse-fortran-type) ( fortran-type-string -- type )
parse-out swap parse-dims swap parse-size swap
>lower fortran>c-types ?at
[ new-fortran-type ] [ misc-type boa ] if ;
: parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ;
GENERIC: added-c-args ( type -- args )
M: fortran-type added-c-args drop { } ;
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ;
GENERIC: returns-by-value? ( type -- ? )
M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ;
M: character-type returns-by-value? fix-character-type single-char? ;
M: complex-type returns-by-value?
{ [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
M: f (fortran-ret-type>c-type) drop c:void ;
M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
M: real-type (fortran-ret-type>c-type)
drop real-functions-return-double? [ c:double ] [ c:float ] if ;
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
: args?dims ( type quot -- main-quot added-quot )
[ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
M: integer-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] }
{ 2 [ [ <short> ] [ drop ] ] }
{ 4 [ [ <int> ] [ drop ] ] }
{ 8 [ [ <longlong> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: logical-type (fortran-arg>c-args)
[ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
M: real-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <float> ] [ drop ] ] }
{ 4 [ [ <float> ] [ drop ] ] }
{ 8 [ [ <double> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: real-complex-type (fortran-arg>c-args)
[
size>> {
{ f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: double-precision-type (fortran-arg>c-args)
[ drop [ <double> ] [ drop ] ] args?dims ;
M: double-complex-type (fortran-arg>c-args)
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args)
fix-character-type single-char?
[ [ first <char> ] [ drop ] ]
[ [ ascii string>alien ] [ length ] ] if ;
M: misc-type (fortran-arg>c-args)
drop [ ] [ drop ] ;
GENERIC: (fortran-result>) ( type -- quots )
: result?dims ( type quot -- quot )
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
M: integer-type (fortran-result>)
[ size>> {
{ f [ { [ *int ] } ] }
{ 1 [ { [ *char ] } ] }
{ 2 [ { [ *short ] } ] }
{ 4 [ { [ *int ] } ] }
{ 8 [ { [ *longlong ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: logical-type (fortran-result>)
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
M: real-type (fortran-result>)
[ size>> {
{ f [ { [ *float ] } ] }
{ 4 [ { [ *float ] } ] }
{ 8 [ { [ *double ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: real-complex-type (fortran-result>)
[ size>> {
{ f [ { [ *complex-float ] } ] }
{ 8 [ { [ *complex-float ] } ] }
{ 16 [ { [ *complex-double ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
M: double-precision-type (fortran-result>)
[ drop { [ *double ] } ] result?dims ;
M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>)
fix-character-type single-char?
[ { [ *char 1string ] } ]
[ { [ ] [ ascii alien>nstring ] } ] if ;
M: misc-type (fortran-result>)
drop { [ ] } ;
GENERIC: (<fortran-result>) ( type -- quot )
M: fortran-type (<fortran-result>)
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
M: character-type (<fortran-result>)
fix-character-type dims>> product dup
[ \ <byte-array> ] dip [ ] 3sequence ;
: [<fortran-result>] ( return parameters -- quot )
[ parse-fortran-type ] dip
over returns-by-value?
[ 2drop [ ] ]
[ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
: [fortran-args>c-args] ( parameters -- quot )
[ [ ] ] [
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
[ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
\ ncleave [ ] 3sequence
] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke
5 [ ] nsequence
c-parameters length \ nkeep
[ ] 3sequence ;
: [fortran-out-param>] ( parameter -- quot )
parse-fortran-type
[ (fortran-result>) ] [ out?>> ] bi
[ ] [ [ drop [ drop ] ] map ] if ;
: [fortran-return>] ( return -- quot )
parse-fortran-type {
{ [ dup not ] [ drop { } ] }
{ [ dup returns-by-value? ] [ drop { [ ] } ] }
[ (fortran-result>) ]
} cond ;
: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
: (shuffle-map) ( return parameters -- ret par )
[
fortran-ret-type>c-type length swap void? [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
[ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
: (fortran-in-shuffle) ( ret par -- seq )
[ second ] sort-with append ;
: (fortran-out-shuffle) ( ret par -- seq )
append ;
: [fortran-result-shuffle] ( return parameters -- quot )
(shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
\ shuffle-effect [ ] 2sequence ;
: [fortran-results>] ( return parameters -- quot )
[ [fortran-result-shuffle] ]
[ drop [fortran-return>] ]
[ nip [ [fortran-out-param>] ] map concat ] 2tri
append
\ spread [ ] 2sequence append ;
: (add-fortran-library) ( fortran-abi name -- )
library-fortran-abis get-global set-at ;
PRIVATE>
: add-fortran-library ( name soname fortran-abi -- )
[ fortran-abi [ fortran-c-abi ] with-variable add-library ]
[ nip swap (add-fortran-library) ] 3bi ;
: fortran-name>symbol-name ( fortran-name -- c-name )
mangle-name ;
: fortran-type>c-type ( fortran-type -- c-type )
parse-fortran-type (fortran-type>c-type) ;
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
[ (fortran-type>c-type) resolve-pointer-type ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
c:void swap
[ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
[ length <vector> 1 <vector> ] keep
[ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
append >array ;
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
: (fortran-invoke) ( return library function parameters -- quot )
{
[ 2nip [<fortran-result>] ]
[ nip nip nip [fortran-args>c-args] ]
[ [fortran-invoke] ]
[ 2nip [fortran-results>] ]
} 4 ncleave 4 nappend ;
MACRO: fortran-invoke ( return library function parameters -- )
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
:: define-fortran-function ( return library function parameters -- )
function create-in dup reset-generic
return library function parameters return [ c:void ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ set-fortran-abi ] bi ;

1
basis/alien/fortran/summary.txt Normal file
View File

@ -0,0 +1 @@
GNU Fortran/G77/F2C alien interface

2
basis/alien/fortran/tags.txt Normal file
View File

@ -0,0 +1,2 @@
fortran
ffi

0
core/alien/remote-control/authors.txt → basis/alien/libraries/authors.txt
View File

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

@ -0,0 +1,75 @@
! 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 strings ;
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" string } { "library" assoc } }
{ $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" { $maybe alien } } }
{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable. If the symbol was not found, outputs " { $link f } "." } ;
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" 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" string } { "path" 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. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
$nl
"This ensures that if the logical library is later used in the same file, for example by a " { $link POSTPONE: FUNCTION: } " definition. Otherwise, the " { $link add-library } " call will happen too late, after compilation, and the C function calls will not refer to the correct library."
$nl
"For details about parse-time evaluation, see " { $link "syntax-immediate" } "." }
{ $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: << } "." } ;
HELP: remove-library
{ $values { "name" string } }
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
ARTICLE: "loading-libs" "Loading native libraries"
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
{ $subsections
add-library
remove-library
}
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsections load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;

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

@ -0,0 +1,10 @@
USING: alien.libraries alien.syntax tools.test kernel ;
IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
[ "fdasfsf" dll-valid? drop ] must-fail

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

@ -0,0 +1,34 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
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 ;
M: dll dispose dlclose ;
M: library dispose dll>> [ dispose ] when* ;
: remove-library ( name -- )
libraries get delete-at* [ dispose ] [ drop ] if ;
: add-library ( name path abi -- )
[ 2drop remove-library ]
[ <library> swap libraries get set-at ] 3bi ;

46
basis/alien/parser/parser-tests.factor Normal file
View File

@ -0,0 +1,46 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser parser eval vocabs.parser debugger
continuations ;
IN: alien.parser.tests
TYPEDEF: char char2
SYMBOL: not-c-type
CONSTANT: eleven 11
[
"alien.parser.tests" use-vocab
"alien.c-types" use-vocab
[ int ] [ "int" parse-c-type ] unit-test
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
[ void* ] [ "int*" parse-c-type ] unit-test
[ void* ] [ "int**" parse-c-type ] unit-test
[ void* ] [ "int***" parse-c-type ] unit-test
[ void* ] [ "int****" parse-c-type ] unit-test
[ char* ] [ "char*" parse-c-type ] unit-test
[ void* ] [ "char**" parse-c-type ] unit-test
[ void* ] [ "char***" parse-c-type ] unit-test
[ void* ] [ "char****" parse-c-type ] unit-test
[ char2 ] [ "char2" parse-c-type ] unit-test
[ char* ] [ "char2*" parse-c-type ] unit-test
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
] with-file-vocabs
! Reported by mnestic
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
[ "OK!" ] [
[
"USE: specialized-arrays SPECIALIZED-ARRAY: alien-parser-test-int" eval( -- )
! after restart, we end up here
"OK!"
] [ :1 ] recover
] unit-test

118
basis/alien/parser/parser.factor Normal file
View File

@ -0,0 +1,118 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.parser
alien.libraries arrays assocs classes combinators
combinators.short-circuit compiler.units effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
IN: alien.parser
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop parse-word ] map ] dip ;
: (parse-c-type) ( string -- type )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
: parse-c-type ( string -- type )
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]
[ parse-c-type ] if ;
: reset-c-type ( word -- )
dup "struct-size" word-prop
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
{
"c-type"
"pointer-c-type"
"callback-effect"
"callback-library"
} reset-props ;
: CREATE-C-TYPE ( -- word )
scan current-vocab create {
[ fake-definition ]
[ set-word ]
[ reset-c-type ]
[ ]
} cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi
[ parse-c-type ] dip ;
: parse-arglist ( parameters return -- types effect )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return! library function! parameters -- word quot effect )
return function normalize-c-arg function! return!
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
: parse-arg-tokens ( -- tokens )
";" parse-tokens [ "()" subseq? not ] filter ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan parse-arg-tokens make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
: library-abi ( lib -- abi )
library [ abi>> ] [ "cdecl" ] if* ;
:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> ( types callback-effect )
type-word callback-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
scan scan parse-arg-tokens make-callback-type ;
PREDICATE: alien-function-word < word
def>> {
[ length 5 = ]
[ last \ alien-invoke eq? ]
} 1&& ;
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;

1
basis/alien/parser/summary.txt Normal file
View File

@ -0,0 +1 @@
Utilities used in implementation of alien parsing words

85
basis/alien/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,85 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators alien alien.strings alien.c-types
alien.parser alien.syntax arrays assocs effects math.parser
prettyprint.backend prettyprint.custom prettyprint.sections
definitions see see.private sequences strings words ;
IN: alien.prettyprint
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address >hex text ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
M: c-type-word definer drop \ C-TYPE: f ;
M: c-type-word definition drop f ;
M: c-type-word declarations. drop ;
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
M: typedef-word definer drop \ TYPEDEF: f ;
M: typedef-word synopsis*
{
[ seeing-word ]
[ definer. ]
[ "c-type" word-prop pprint-c-type ]
[ pprint-word ]
} cleave ;
: pprint-function-arg ( type name -- )
[ pprint-c-type ] [ text ] bi* ;
: pprint-function-args ( types names -- )
zip [ ] [
unclip-last
[ [ first2 "," append pprint-function-arg ] each ] dip
first2 pprint-function-arg
] if-empty ;
: pprint-library ( library -- )
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> fourth ] [ stack-effect in>> ] bi
pprint-function-args
")" text block>
]
} cleave ;
M: alien-callback-type-word definer
drop \ CALLBACK: \ ; ;
M: alien-callback-type-word definition drop f ;
M: alien-callback-type-word synopsis*
{
[ seeing-word ]
[ "callback-library" word-prop pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> second ] [ "callback-effect" word-prop in>> ] bi
pprint-function-args
")" text block>
]
} cleave ;

1
basis/alien/prettyprint/summary.txt Normal file
View File

@ -0,0 +1 @@
Prettyprinting aliens and DLLs

0
core/alien/structs/authors.txt → basis/alien/remote-control/authors.txt
View File

44
basis/alien/remote-control/remote-control-tests.factor Normal file
View File

@ -0,0 +1,44 @@
USING: interpolate multiline
io io.directories io.encodings.ascii io.files
io.files.temp io.launcher io.streams.string kernel locals system
tools.test sequences ;
IN: alien.remote-control.tests
: compile-file ( contents -- )
"test.c" ascii set-file-contents
{ "gcc" "-I../" "-L.." "-lfactor" "test.c" }
os macosx? cpu x86.64? and [ "-m64" suffix ] when
try-process ;
: run-test ( -- line )
os windows? "temp/a.exe" "temp/a.out" ?
ascii [ readln ] with-process-reader ;
:: test-embedding ( code -- line )
image :> image
[
I[
#include <vm/master.h>
#include <stdio.h>
#include <stdbool.h>
int main(int argc, char **argv)
{
F_PARAMETERS p;
default_parameters(&p);
p.image_path = STRING_LITERAL("${image}");
init_factor(&p);
start_embedded_factor(&p);
${code}
printf("Done.\n");
return 0;
}
]I
] with-string-writer
"resource:temp" [ compile-file ] with-directory
"resource:" [ run-test ] with-directory ;
! [ "Done." ] [ "" test-embedding ] unit-test
! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test

26
basis/alien/remote-control/remote-control.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
parser threads words kernel.private kernel io.encodings.utf8
eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
void* { char* } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
void { } "cdecl" [ yield ] alien-callback ;
: sleep-callback ( -- callback )
void { long } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 set-special-object
\ yield-callback ?callback 17 set-special-object
\ sleep-callback ?callback 18 set-special-object ;
MAIN: init-remote-control

0
core/alien/remote-control/summary.txt → basis/alien/remote-control/summary.txt
View File

0
core/alien/syntax/authors.txt → basis/alien/syntax/authors.txt
View File

0
core/alien/syntax/summary.txt → basis/alien/syntax/summary.txt
View File

123
basis/alien/syntax/syntax-docs.factor Normal file
View File

@ -0,0 +1,123 @@
IN: alien.syntax
USING: alien alien.c-types alien.parser alien.libraries
classes.struct help.markup help.syntax see ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
{ $values { "path" "a pathname string" } }
{ $description "Constructs a DLL handle at parse time." } ;
HELP: ALIEN:
{ $syntax "ALIEN: address" }
{ $values { "address" "a non-negative hexadecimal integer" } }
{ $description "Creates an alien object at parse time." }
{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
ARTICLE: "syntax-aliens" "Alien object literal syntax"
{ $subsections
POSTPONE: ALIEN:
POSTPONE: DLL"
} ;
HELP: LIBRARY:
{ $syntax "LIBRARY: name" }
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: C-GLOBAL: } " and " { $link POSTPONE: CALLBACK: } " definitions, as well as " { $link POSTPONE: &: } " forms." }
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
HELP: FUNCTION:
{ $syntax "FUNCTION: return name ( parameters )" }
{ $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
$nl
"The new word must be compiled before being executed." }
{ $examples
"For example, suppose the " { $snippet "foo" } " library exports the following function:"
{ $code
"void the_answer(char* question, int value) {"
" printf(\"The answer to %s is %d.\n\",question,value);"
"}"
}
"You can define a word for invoking it:"
{ $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler"
"\"the question\" 42 the_answer"
"The answer to the question is 42."
} }
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
{ $code
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
"FUNCTION: void glHint GLenum target GLenum mode ;"
} } ;
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
{ $values { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
{ $examples
"Here is an example enumeration definition:"
{ $code "C-ENUM: red green blue ;" }
"It is equivalent to the following series of definitions:"
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
HELP: C-TYPE:
{ $syntax "C-TYPE: type" }
{ $values { "type" "a new C type" } }
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
{ $code """C-TYPE: forward
STRUCT: backward { x forward* } ;
STRUCT: forward { x backward* } ; """ } }
{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." }
{ $examples
{ $code
"CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
": MyFakeCallback ( -- alien )"
" [| message payload |"
" \"message #\" write"
" message number>string write"
" \" received\" write nl"
" t"
" ] FakeCallback ;"
}
} ;
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C global variable name" } }
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
HELP: typedef
{ $values { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;

49
basis/alien/syntax/syntax.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types
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 alien.libraries ;
IN: alien.syntax
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
SYNTAX: CALLBACK:
(CALLBACK:) define-inline ;
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE dup save-location typedef ;
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] append! ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;

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

82
basis/ascii/ascii-docs.factor Normal file
View File

@ -0,0 +1,82 @@
USING: help.markup help.syntax ;
IN: ascii
HELP: blank?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII whitespace character." } ;
HELP: letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a lowercase alphabet ASCII character." } ;
HELP: LETTER?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a uppercase alphabet ASCII character." } ;
HELP: digit?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII decimal digit character." } ;
HELP: Letter?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
HELP: alpha?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an alphanumeric ASCII character." } ;
HELP: printable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a printable ASCII character." } ;
HELP: control?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII control character." } ;
HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ascii?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for whether a number is an ASCII character." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts an ASCII character to lower case." } ;
HELP: ch>upper
{ $values { "ch" "a character" } { "upper" "a character" } }
{ $description "Converts an ASCII character to upper case." } ;
HELP: >lower
{ $values { "str" "a string" } { "lower" "a string" } }
{ $description "Converts an ASCII string to lower case." } ;
HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } }
{ $description "Converts an ASCII string to upper case." } ;
ARTICLE: "ascii" "ASCII"
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
$nl
"ASCII character classes:"
{ $subsections
blank?
letter?
LETTER?
digit?
printable?
control?
quotable?
ascii?
}
"ASCII case conversion:"
{ $subsections
ch>lower
ch>upper
>lower
>upper
} ;
ABOUT: "ascii"

19
basis/ascii/ascii-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: ascii tools.test sequences kernel math ;
IN: ascii.tests
[ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test
[ f ] [ CHAR: a LETTER? ] unit-test
[ t ] [ CHAR: A LETTER? ] unit-test
[ t ] [ CHAR: 0 digit? ] unit-test
[ f ] [ CHAR: x digit? ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
[ LETTER? [ 1 + ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test

23
basis/ascii/ascii.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences strings
combinators.short-circuit hints ;
IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
: >lower ( str -- lower ) [ ch>lower ] map ;
: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
: >upper ( str -- upper ) [ ch>upper ] map ;
HINTS: >lower string ;
HINTS: >upper string ;

0
core/bit-arrays/authors.txt → basis/ascii/authors.txt Normal file → Executable file
View File

1
basis/ascii/summary.txt Executable file
View File

@ -0,0 +1 @@
ASCII character classes

1
basis/ascii/tags.txt Executable file
View File

@ -0,0 +1 @@
text

0
extra/calendar/authors.txt → basis/base64/authors.txt
View File

51
basis/base64/base64-docs.factor Normal file
View File

@ -0,0 +1,51 @@
USING: help.markup help.syntax kernel math sequences ;
IN: base64
HELP: >base64
{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." }
{ $examples
{ $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
}
{ $see-also base64> >base64-lines } ;
HELP: >base64-lines
{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." }
{ $see-also base64> >base64-lines } ;
HELP: base64>
{ $values { "base64" "a string of base64 characters" } { "seq" sequence } }
{ $description "Converts a string in base64 encoding back into its binary representation." }
{ $examples
{ $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
}
{ $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
{ $see-also >base64 >base64-lines } ;
HELP: encode-base64
{ $description "Reads the standard input and writes it to standard output encoded in base64." } ;
HELP: decode-base64
{ $description "Reads the standard input and decodes it, writing to standard output." } ;
HELP: encode-base64-lines
{ $description "Reads the standard input and writes it to standard output encoded in base64 with a crlf every 76 characters." } ;
ARTICLE: "base64" "Base 64 conversions"
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
"Converting to and from base64 as strings:"
{ $subsections
>base64
>base64-lines
base64>
}
"Using base64 from streams:"
{ $subsections
encode-base64
encode-base64-lines
decode-base64
} ;
ABOUT: "base64"

27
basis/base64/base64-tests.factor Normal file
View File

@ -0,0 +1,27 @@
USING: kernel tools.test base64 strings sequences
io.encodings.string io.encodings.ascii ;
IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
[ "abcde" ] [ "abcde" ascii encode >base64 3 cut "\r\n" swap 3append base64> ascii decode ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
ascii encode >base64 >string
] unit-test
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
ascii encode >base64-lines >string
] unit-test
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with

85
basis/base64/base64.factor Normal file
View File

@ -0,0 +1,85 @@
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
ERROR: malformed-base64 ;
<PRIVATE
: read1-ignoring ( ignoring -- ch )
read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
: read-ignoring ( ignoring n -- str )
[ drop read1-ignoring ] with { } map-integers
[ { f 0 } member? not ] filter
[ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
nth ; inline
: base64>ch ( ch -- ch )
{
f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
f f f f f f f f f f 62 f f f 63 52 53 54 55 56 57 58 59 60 61 f f
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 [ malformed-base64 ] unless* ; inline
SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
: write-lines ( str -- )
[ write1-lines ] each ;
: encode3 ( seq -- )
be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
[ write1 ] each ; inline
PRIVATE>
: encode-base64 ( -- )
3 read dup length {
{ 0 [ drop ] }
{ 3 [ encode3 encode-base64 ] }
[ encode-pad encode-base64 ]
} case ;
: encode-base64-lines ( -- )
0 column [ encode-base64 ] with-variable ;
: decode-base64 ( -- )
"\n\r" 4 read-ignoring dup length {
{ 0 [ drop ] }
{ 4 [ decode4 decode-base64 ] }
[ malformed-base64 ]
} case ;
: >base64 ( seq -- base64 )
binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
: base64> ( base64 -- seq )
binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
: >base64-lines ( seq -- base64 )
binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;

0
extra/base64/summary.txt → basis/base64/summary.txt
View File

2
basis/base64/tags.txt Normal file
View File

@ -0,0 +1,2 @@
parsing
web

0
core/bootstrap/compiler/authors.txt → basis/biassocs/authors.txt
View File

41
basis/biassocs/biassocs-docs.factor Normal file
View File

@ -0,0 +1,41 @@
IN: biassocs
USING: help.markup help.syntax assocs kernel ;
HELP: biassoc
{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ;
HELP: <biassoc>
{ $values { "exemplar" assoc } { "biassoc" biassoc } }
{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ;
HELP: <bihash>
{ $values { "biassoc" biassoc } }
{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ;
HELP: once-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
HELP: >biassoc
{ $values { "assoc" assoc } { "biassoc" biassoc } }
{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
ARTICLE: "biassocs" "Bidirectional assocs"
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
$nl
"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
$nl
"The class of biassocs:"
{ $subsections
biassoc
biassoc?
}
"Creating new biassocs:"
{ $subsections
<biassoc>
<bihash>
}
"Converting existing assocs to biassocs:"
{ $subsections >biassoc } ;
ABOUT: "biassocs"

42
basis/biassocs/biassocs-tests.factor Normal file
View File

@ -0,0 +1,42 @@
USING: biassocs assocs namespaces tools.test hashtables kernel ;
IN: biassocs.tests
<bihash> "h" set
[ 0 ] [ "h" get assoc-size ] unit-test
[ ] [ 1 2 "h" get set-at ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
[ 2 ] [ 1 "h" get value-at ] unit-test
[ 1 ] [ "h" get assoc-size ] unit-test
[ ] [ 1 3 "h" get set-at ] unit-test
[ 1 ] [ 3 "h" get at ] unit-test
[ 2 ] [ 1 "h" get value-at ] unit-test
[ 2 ] [ "h" get assoc-size ] unit-test
H{ { "a" "A" } { "b" "B" } } "a" set
[ ] [ "a" get >biassoc "b" set ] unit-test
[ t ] [ "b" get biassoc? ] unit-test
[ "A" ] [ "a" "b" get at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
[ ] [ "h" get clone "g" set ] unit-test
[ ] [ 3 4 "g" get set-at ] unit-test
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

49
basis/biassocs/biassocs.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs accessors summary hashtables ;
IN: biassocs
TUPLE: biassoc from to ;
: <biassoc> ( exemplar -- biassoc )
[ clone ] [ clone ] bi biassoc boa ;
: <bihash> ( -- biassoc )
H{ } <biassoc> ;
M: biassoc assoc-size from>> assoc-size ;
M: biassoc at* from>> at* ;
M: biassoc value-at* to>> at* ;
: once-at ( value key assoc -- )
2dup key? [ 3drop ] [ set-at ] if ;
M: biassoc set-at
[ from>> set-at ] [ swapd to>> once-at ] 3bi ;
ERROR: no-biassoc-deletion ;
M: no-biassoc-deletion summary
drop "biassocs do not support deletion" ;
M: biassoc delete-at
no-biassoc-deletion ;
M: biassoc >alist
from>> >alist ;
M: biassoc clear-assoc
[ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
M: biassoc new-assoc
drop [ <hashtable> ] [ <hashtable> ] bi biassoc boa ;
INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc )
T{ biassoc } assoc-clone-like ;
M: biassoc clone
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

1
basis/biassocs/summary.txt Normal file
View File

@ -0,0 +1 @@
Bidirectional assocs

0
core/bit-arrays/tags.txt → basis/biassocs/tags.txt
View File

59
basis/binary-search/binary-search-docs.factor Normal file
View File

@ -0,0 +1,59 @@
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 } } }
{ $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+ } "."
$nl
"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
{ $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 find } "." }
{ $examples
"Searching for an integer in a sorted array:"
{ $example
"USING: binary-search math.order prettyprint ;"
"{ -13 -4 1 9 16 17 28 } [ 5 >=< ] search . ."
"1\n2"
}
"Frequently, the quotation passed to " { $link search } " is constructed by " { $link curry } " or " { $link with } " in order to make the search key a parameter:"
{ $example
"USING: binary-search kernel math.order prettyprint ;"
"5 { -13 -4 1 9 16 17 28 } [ <=> ] with search . ."
"1\n2"
}
} ;
{ find find-from find-last find-last find-last-from search } related-words
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
{ $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
HELP: sorted-member?
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a 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" } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
{ member-eq? sorted-member-eq? } related-words
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsections search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsections
sorted-index
sorted-member?
sorted-member-eq?
}
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"

15
basis/binary-search/binary-search-tests.factor Normal file
View File

@ -0,0 +1,15 @@
USING: binary-search math.order sequences kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

53
basis/binary-search/binary-search.factor Normal file
View File

@ -0,0 +1,53 @@
! 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 ;
IN: binary-search
<PRIVATE
: midpoint ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline
: decide ( quot seq -- quot seq <=> )
[ midpoint swap call ] 2keep rot ; inline
: finish ( quot slice -- i elt )
[ [ 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+ [ [ (head) ] keep-searching ] }
{ +gt+ [ [ (tail) ] keep-searching ] }
} case
] if ; inline recursive
PRIVATE>
: search ( seq quot -- i elt )
over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
inline
: natural-search ( obj seq -- i elt )
[ <=> ] with search ;
HINTS: natural-search array ;
: sorted-index ( obj seq -- i )
natural-search drop ;
: sorted-member? ( obj seq -- ? )
dupd natural-search nip = ;
: sorted-member-eq? ( obj seq -- ? )
dupd natural-search nip eq? ;

1
basis/binary-search/summary.txt Normal file
View File

@ -0,0 +1 @@
Fast searching of sorted arrays

0
core/bootstrap/image/authors.txt → basis/bit-arrays/authors.txt
View File

78
basis/bit-arrays/bit-arrays-docs.factor Normal file
View File

@ -0,0 +1,78 @@
USING: arrays help.markup help.syntax kernel
kernel.private math prettyprint strings vectors sbufs ;
IN: bit-arrays
ARTICLE: "bit-arrays" "Bit arrays"
"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name."
$nl
"Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
$nl
"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
$nl
"Bit arrays form a class of objects:"
{ $subsections
bit-array
bit-array?
}
"Creating new bit arrays:"
{ $subsections
>bit-array
<bit-array>
}
"Efficiently setting and clearing all bits in a bit array:"
{ $subsections
set-bits
clear-bits
}
"Converting between unsigned integers and their binary representation:"
{ $subsections
integer>bit-array
bit-array>integer
}
"Bit array literal syntax:"
{ $subsections POSTPONE: ?{ } ;
ABOUT: "bit-arrays"
HELP: ?{
{ $syntax "?{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?{ t f t }" } } ;
HELP: bit-array
{ $description "The class of fixed-length bit arrays." } ;
HELP: <bit-array> ( n -- bit-array )
{ $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link 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 } }
{ $description "Outputs a freshly-allocated bit array whose elements have the same boolean values as a given sequence." } ;
HELP: clear-bits
{ $values { "bit-array" bit-array } }
{ $description "Sets all elements of the bit array to " { $link f } "." }
{ $notes "Calling this word is more efficient than the following:"
{ $code "[ drop f ] map! drop" }
}
{ $side-effects "bit-array" } ;
HELP: set-bits
{ $values { "bit-array" bit-array } }
{ $description "Sets all elements of the bit array to " { $link t } "." }
{ $notes "Calling this word is more efficient than the following:"
{ $code "[ drop t ] map! drop" }
}
{ $side-effects "bit-array" } ;
HELP: integer>bit-array
{ $values { "n" integer } { "bit-array" bit-array } }
{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
HELP: bit-array>integer
{ $values { "bit-array" bit-array } { "n" integer } }
{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;

82
basis/bit-arrays/bit-arrays-tests.factor Normal file
View File

@ -0,0 +1,82 @@
USING: sequences sequences.private arrays bit-arrays kernel
tools.test math random ;
IN: bit-arrays.tests
[ 100 ] [ 100 <bit-array> length ] unit-test
[
{ t f t }
] [
3 <bit-array> t 0 pick set-nth t 2 pick set-nth
>array
] unit-test
[
{ t f t }
] [
{ t f t } >bit-array >array
] unit-test
[
{ t f t } { f t f }
] [
{ t f t } >bit-array dup clone [ not ] map!
[ >array ] bi@
] unit-test
[
{ f f f f f }
] [
{ t f t t f } >bit-array dup clear-bits >array
] unit-test
[
{ t t t t t }
] [
{ t f t t f } >bit-array dup set-bits >array
] unit-test
[ t ] [
100 [
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all-integers?
] unit-test
[ ?{ f } ] [
1 2 { t f t f } <slice> >bit-array
] unit-test
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize ] unit-test
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize ] unit-test
[ -10 ?{ } resize ] must-fail
[ -1 integer>bit-array ] must-fail
[ ?{ } ] [ 0 integer>bit-array ] unit-test
[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
[ ?{
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
} ] [
HEX: ffffffffffffffffffffffffffffffff integer>bit-array
] unit-test
[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
[ 0 ] [ ?{ } bit-array>integer ] unit-test
[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
} bit-array>integer ] unit-test
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

110
basis/bit-arrays/bit-arrays.factor Normal file
View File

@ -0,0 +1,110 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
IN: bit-arrays
TUPLE: bit-array
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
<PRIVATE
: n>byte ( m -- n ) -3 shift ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
: bits>cells ( m -- n ) 31 + -5 shift ; inline
: bits>bytes ( m -- n ) 7 + n>byte ; inline
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
dup underlying>> empty? [ drop ] [
[
[ underlying>> length 8 * ] [ length ] bi -
8 swap - -1 swap shift bitnot
]
[ underlying>> last bitand ]
[ underlying>> set-last ]
tri
] if ; inline
PRIVATE>
: <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline
M: bit-array length length>> ; inline
M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ; inline
GENERIC: clear-bits ( bit-array -- )
M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- )
M: bit-array set-bits -1 (set-bits) ; inline
M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
M: bit-array resize
[ drop ] [
[ bits>bytes ] [ underlying>> ] bi*
resize-byte-array
] 2bi
bit-array boa
dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array )
dup 0 = [
<bit-array>
] [
[ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;
: bit-array>integer ( bit-array -- n )
0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;
INSTANCE: bit-array sequence
M: bit-array pprint-delims drop \ ?{ \ } ;
M: bit-array >pprint-sequence ;
M: bit-array pprint* pprint-object ;

0
core/bit-arrays/summary.txt → basis/bit-arrays/summary.txt
View File

0
core/dlists/tags.txt → basis/bit-arrays/tags.txt
View File

0
core/command-line/authors.txt → basis/bit-sets/authors.txt
View File

17
basis/bit-sets/bit-sets-tests.factor Normal file
View File

@ -0,0 +1,17 @@
USING: bit-sets tools.test bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-union
] unit-test
[ ?{ f f f f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-intersect
] unit-test
[ ?{ t f t f f f } ] [
?{ t t t f f f }
?{ f t f f t t } bit-set-diff
] unit-test

31
basis/bit-sets/bit-sets.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
IN: bit-sets
<PRIVATE
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
[
[ [ length ] bi@ assert= ]
[ [ underlying>> ] bi@ ] 2bi
] dip 2map
] 3bi bit-array boa ; inline
PRIVATE>
: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
HINTS: bit-set-union bit-array bit-array ;
: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
HINTS: bit-set-intersect bit-array bit-array ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
HINTS: bit-set-diff bit-array bit-array ;
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;

1
basis/bit-sets/summary.txt Normal file
View File

@ -0,0 +1 @@
Efficient bitwise operations on bit arrays

41
basis/bit-vectors/bit-vectors-docs.factor Normal file
View File

@ -0,0 +1,41 @@
USING: arrays bit-arrays help.markup help.syntax kernel
combinators ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsections
bit-vector
bit-vector?
}
"Creating bit vectors:"
{ $subsections
>bit-vector
<bit-vector>
}
"Literal syntax:"
{ $subsections POSTPONE: ?V{ }
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
{ $code "?V{ } clone" } ;
ABOUT: "bit-vectors"
HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" 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 } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{
{ $syntax "?V{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?V{ t f t }" } } ;

14
basis/bit-vectors/bit-vectors-tests.factor Normal file
View File

@ -0,0 +1,14 @@
USING: tools.test bit-vectors vectors sequences kernel math ;
IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each-integer ;
[ t ] [
3 <bit-vector> dup do-it
3 <vector> dup do-it sequence=
] unit-test
[ t ] [ ?V{ } bit-vector? ] unit-test

15
basis/bit-vectors/bit-vectors.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom
parser accessors vectors.functor classes.parser ;
IN: bit-vectors
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ;

1
basis/bit-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable bit arrays

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