Slava Pestov
commit
a96457cecc
Binary file not shown.
|
|
@ -0,0 +1,74 @@
|
||||||
|
<?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">
|
||||||
|
<plist version="1.0">
|
||||||
|
<dict>
|
||||||
|
<key>CFBundleDocumentTypes</key>
|
||||||
|
<array>
|
||||||
|
<dict>
|
||||||
|
<key>CFBundleTypeExtensions</key>
|
||||||
|
<array>
|
||||||
|
<string>*</string>
|
||||||
|
</array>
|
||||||
|
<key>CFBundleTypeName</key>
|
||||||
|
<string>Any</string>
|
||||||
|
<key>CFBundleTypeOSTypes</key>
|
||||||
|
<array>
|
||||||
|
<string>****</string>
|
||||||
|
</array>
|
||||||
|
<key>CFBundleTypeRole</key>
|
||||||
|
<string>Viewer</string>
|
||||||
|
</dict>
|
||||||
|
</array>
|
||||||
|
<key>CFBundleExecutable</key>
|
||||||
|
<string>factor</string>
|
||||||
|
<key>CFBundleIconFile</key>
|
||||||
|
<string>FRaptorMix.icns</string>
|
||||||
|
<key>CFBundleIdentifier</key>
|
||||||
|
<string>org.factorcode.Factor</string>
|
||||||
|
<key>CFBundleInfoDictionaryVersion</key>
|
||||||
|
<string>6.0</string>
|
||||||
|
<key>CFBundleName</key>
|
||||||
|
<string>Factor</string>
|
||||||
|
<key>CFBundlePackageType</key>
|
||||||
|
<string>APPL</string>
|
||||||
|
<key>NSHumanReadableCopyright</key>
|
||||||
|
<string>Copyright © 2003-2007, Slava Pestov and friends</string>
|
||||||
|
<key>NSServices</key>
|
||||||
|
<array>
|
||||||
|
<dict>
|
||||||
|
<key>NSMenuItem</key>
|
||||||
|
<dict>
|
||||||
|
<key>default</key>
|
||||||
|
<string>Factor/Evaluate in Listener</string>
|
||||||
|
</dict>
|
||||||
|
<key>NSMessage</key>
|
||||||
|
<string>evalInListener</string>
|
||||||
|
<key>NSPortName</key>
|
||||||
|
<string>Factor</string>
|
||||||
|
<key>NSSendTypes</key>
|
||||||
|
<array>
|
||||||
|
<string>NSStringPboardType</string>
|
||||||
|
</array>
|
||||||
|
</dict>
|
||||||
|
<dict>
|
||||||
|
<key>NSMenuItem</key>
|
||||||
|
<dict>
|
||||||
|
<key>default</key>
|
||||||
|
<string>Factor/Evaluate Selection</string>
|
||||||
|
</dict>
|
||||||
|
<key>NSMessage</key>
|
||||||
|
<string>evalToString</string>
|
||||||
|
<key>NSPortName</key>
|
||||||
|
<string>Factor</string>
|
||||||
|
<key>NSReturnTypes</key>
|
||||||
|
<array>
|
||||||
|
<string>NSStringPboardType</string>
|
||||||
|
</array>
|
||||||
|
<key>NSSendTypes</key>
|
||||||
|
<array>
|
||||||
|
<string>NSStringPboardType</string>
|
||||||
|
</array>
|
||||||
|
</dict>
|
||||||
|
</array>
|
||||||
|
</dict>
|
||||||
|
</plist>
|
||||||
|
|
@ -0,0 +1,17 @@
|
||||||
|
{
|
||||||
|
IBClasses = (
|
||||||
|
{
|
||||||
|
ACTIONS = {
|
||||||
|
newFactorWorkspace = id;
|
||||||
|
runFactorFile = id;
|
||||||
|
saveFactorImage = id;
|
||||||
|
saveFactorImageAs = id;
|
||||||
|
showFactorHelp = id;
|
||||||
|
};
|
||||||
|
CLASS = FirstResponder;
|
||||||
|
LANGUAGE = ObjC;
|
||||||
|
SUPERCLASS = NSObject;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
IBVersion = 1;
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,21 @@
|
||||||
|
<?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">
|
||||||
|
<plist version="1.0">
|
||||||
|
<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>
|
||||||
|
<string>439.0</string>
|
||||||
|
<key>IBOpenObjects</key>
|
||||||
|
<array>
|
||||||
|
<integer>29</integer>
|
||||||
|
</array>
|
||||||
|
<key>IBSystem Version</key>
|
||||||
|
<string>8R218</string>
|
||||||
|
</dict>
|
||||||
|
</plist>
|
||||||
Binary file not shown.
|
|
@ -0,0 +1,17 @@
|
||||||
|
{
|
||||||
|
IBClasses = (
|
||||||
|
{
|
||||||
|
ACTIONS = {
|
||||||
|
newFactorWorkspace = id;
|
||||||
|
runFactorFile = id;
|
||||||
|
saveFactorImage = id;
|
||||||
|
saveFactorImageAs = id;
|
||||||
|
showFactorHelp = id;
|
||||||
|
};
|
||||||
|
CLASS = FirstResponder;
|
||||||
|
LANGUAGE = ObjC;
|
||||||
|
SUPERCLASS = NSObject;
|
||||||
|
}
|
||||||
|
);
|
||||||
|
IBVersion = 1;
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,21 @@
|
||||||
|
<?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">
|
||||||
|
<plist version="1.0">
|
||||||
|
<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>
|
||||||
|
<string>439.0</string>
|
||||||
|
<key>IBOpenObjects</key>
|
||||||
|
<array>
|
||||||
|
<integer>29</integer>
|
||||||
|
</array>
|
||||||
|
<key>IBSystem Version</key>
|
||||||
|
<string>8R218</string>
|
||||||
|
</dict>
|
||||||
|
</plist>
|
||||||
BIN
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib
generated
Normal file
BIN
Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib
generated
Normal file
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,154 @@
|
||||||
|
CC = gcc
|
||||||
|
|
||||||
|
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 -fomit-frame-pointer $(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/compiler.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/stack.o \
|
||||||
|
vm/types.o \
|
||||||
|
vm/jit.o \
|
||||||
|
vm/utilities.o
|
||||||
|
|
||||||
|
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||||
|
|
||||||
|
default:
|
||||||
|
@echo "Run 'make' with one of the following parameters:"
|
||||||
|
@echo ""
|
||||||
|
@echo "freebsd-x86"
|
||||||
|
@echo "freebsd-amd64"
|
||||||
|
@echo "linux-x86"
|
||||||
|
@echo "linux-amd64"
|
||||||
|
@echo "linux-ppc"
|
||||||
|
@echo "linux-arm"
|
||||||
|
@echo "openbsd-x86"
|
||||||
|
@echo "openbsd-amd64"
|
||||||
|
@echo "macosx-x86"
|
||||||
|
@echo "macosx-ppc"
|
||||||
|
@echo "solaris-x86"
|
||||||
|
@echo "solaris-amd64"
|
||||||
|
@echo "windows-ce-arm"
|
||||||
|
@echo "windows-ce-x86"
|
||||||
|
@echo "windows-nt-x86"
|
||||||
|
@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:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.x86
|
||||||
|
|
||||||
|
openbsd-amd64:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.openbsd.amd64
|
||||||
|
|
||||||
|
freebsd-x86:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86
|
||||||
|
|
||||||
|
freebsd-amd64:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.amd64
|
||||||
|
|
||||||
|
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: macosx-freetype
|
||||||
|
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86
|
||||||
|
|
||||||
|
linux-x86:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86
|
||||||
|
|
||||||
|
linux-amd64:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.amd64
|
||||||
|
|
||||||
|
linux-ppc:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.ppc
|
||||||
|
|
||||||
|
linux-arm:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.arm
|
||||||
|
|
||||||
|
solaris-x86:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86
|
||||||
|
|
||||||
|
solaris-amd64:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.amd64
|
||||||
|
|
||||||
|
windows-nt-x86:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86
|
||||||
|
|
||||||
|
windows-ce-arm:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
|
||||||
|
|
||||||
|
windows-ce-x86:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.x86
|
||||||
|
|
||||||
|
macosx.app: factor
|
||||||
|
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)
|
||||||
|
|
||||||
|
pull:
|
||||||
|
darcs pull http://factorcode.org/repos/
|
||||||
|
|
||||||
|
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
|
||||||
|
|
@ -0,0 +1,180 @@
|
||||||
|
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
|
||||||
|
|
||||||
|
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:
|
||||||
|
|
@ -0,0 +1,527 @@
|
||||||
|
USING: byte-arrays arrays help.syntax help.markup
|
||||||
|
alien.syntax alien.c-types compiler definitions math libc
|
||||||
|
debugger parser io io.backend system bit-arrays float-arrays ;
|
||||||
|
IN: alien
|
||||||
|
|
||||||
|
HELP: alien
|
||||||
|
{ $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-data" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: dll
|
||||||
|
{ $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: expired? ( c-ptr -- ? )
|
||||||
|
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
|
||||||
|
$nl
|
||||||
|
"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
|
||||||
|
|
||||||
|
HELP: <displaced-alien> ( displacement c-ptr -- alien )
|
||||||
|
{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
|
||||||
|
{ $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $snippet "c-ptr" } "." }
|
||||||
|
{ $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link <alien> } " is implemented."
|
||||||
|
$nl
|
||||||
|
"Passing a zero absolute address does not construct a new alien object, but instead makes the word output " { $link f } "." } ;
|
||||||
|
|
||||||
|
{ <alien> <displaced-alien> alien-address } related-words
|
||||||
|
|
||||||
|
HELP: alien-address ( c-ptr -- addr )
|
||||||
|
{ $values { "c-ptr" "an alien or " { $link f } } { "addr" "a non-negative integer" } }
|
||||||
|
{ $description "Outputs the address of an alien." }
|
||||||
|
{ $notes "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
|
||||||
|
|
||||||
|
HELP: <alien>
|
||||||
|
{ $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }
|
||||||
|
{ $description "Creates an alien object, wrapping a raw memory address." }
|
||||||
|
{ $notes "Alien objects are invalidated between image saves and loads." } ;
|
||||||
|
|
||||||
|
HELP: c-ptr
|
||||||
|
{ $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
|
||||||
|
|
||||||
|
HELP: library
|
||||||
|
{ $values { "name" "a string" } { "library" "a hashtable" } }
|
||||||
|
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||||
|
{ $list
|
||||||
|
{ { $snippet "name" } " - the full path of the C library binary" }
|
||||||
|
{ { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
|
||||||
|
{ { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: dlopen ( path -- dll )
|
||||||
|
{ $values { "path" "a pathname string" } { "dll" "a DLL handle" } }
|
||||||
|
{ $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
|
||||||
|
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
|
||||||
|
{ $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
|
||||||
|
|
||||||
|
HELP: dlsym ( name dll -- alien )
|
||||||
|
{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" "an alien pointer" } }
|
||||||
|
{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable." }
|
||||||
|
{ $errors "Throws an error if the symbol could not be found." } ;
|
||||||
|
|
||||||
|
HELP: dlclose ( dll -- )
|
||||||
|
{ $values { "dll" "a DLL handle" } }
|
||||||
|
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
|
||||||
|
|
||||||
|
HELP: load-library
|
||||||
|
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
|
||||||
|
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
|
||||||
|
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
|
||||||
|
|
||||||
|
HELP: add-library
|
||||||
|
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
|
||||||
|
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
|
||||||
|
{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ;
|
||||||
|
|
||||||
|
HELP: alien-invoke-error
|
||||||
|
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||||
|
{ $list
|
||||||
|
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||||
|
{ "The return type or parameter list references an unknown C type." }
|
||||||
|
{ "The symbol or library could not be found." }
|
||||||
|
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: alien-invoke
|
||||||
|
{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
|
||||||
|
{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected." }
|
||||||
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
|
||||||
|
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ;
|
||||||
|
|
||||||
|
HELP: alien-indirect-error
|
||||||
|
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||||
|
{ $list
|
||||||
|
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||||
|
{ "The return type or parameter list references an unknown C type." }
|
||||||
|
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: alien-indirect
|
||||||
|
{ $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
|
||||||
|
{ $description
|
||||||
|
"Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected."
|
||||||
|
}
|
||||||
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
|
||||||
|
{ $errors "Throws an " { $link alien-indirect-error } " if the word calling " { $link alien-indirect } " is not compiled." } ;
|
||||||
|
|
||||||
|
HELP: alien-callback-error
|
||||||
|
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||||
|
{ $list
|
||||||
|
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||||
|
{ "The return type or parameter list references an unknown C type." }
|
||||||
|
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: alien-callback
|
||||||
|
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" c-ptr } }
|
||||||
|
{ $description
|
||||||
|
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
|
||||||
|
$nl
|
||||||
|
"When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
|
||||||
|
$nl
|
||||||
|
"Callback quotations run with freshly-allocated stacks. This means the data stack contains the values passed by the C function, and nothing else. It also means that if the callback throws an error which is not caught, the Factor runtime will halt. See " { $link "errors" } " for error handling options."
|
||||||
|
}
|
||||||
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
|
||||||
|
{ $examples
|
||||||
|
"A simple example, showing a C function which returns the difference of two given integers:"
|
||||||
|
{ $code
|
||||||
|
": difference-callback ( -- alien )"
|
||||||
|
" \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
|
||||||
|
|
||||||
|
{ alien-invoke alien-indirect alien-callback } related-words
|
||||||
|
|
||||||
|
ARTICLE: "aliens" "Alien addresses"
|
||||||
|
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
|
||||||
|
{ $subsection <alien> }
|
||||||
|
{ $subsection <displaced-alien> }
|
||||||
|
{ $subsection alien-address }
|
||||||
|
{ $subsection expired? }
|
||||||
|
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
|
||||||
|
$nl
|
||||||
|
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "c-structs" "C structure types"
|
||||||
|
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
||||||
|
{ $subsection POSTPONE: C-STRUCT: }
|
||||||
|
"Great care must be taken when working with C structures since no type or bounds checking is possible."
|
||||||
|
$nl
|
||||||
|
"An example:"
|
||||||
|
{ $code
|
||||||
|
"C-STRUCT: XVisualInfo"
|
||||||
|
" { \"Visual*\" \"visual\" }"
|
||||||
|
" { \"VisualID\" \"visualid\" }"
|
||||||
|
" { \"int\" \"screen\" }"
|
||||||
|
" { \"uint\" \"depth\" }"
|
||||||
|
" { \"int\" \"class\" }"
|
||||||
|
" { \"ulong\" \"red_mask\" }"
|
||||||
|
" { \"ulong\" \"green_mask\" }"
|
||||||
|
" { \"ulong\" \"blue_mask\" }"
|
||||||
|
" { \"int\" \"colormap_size\" }"
|
||||||
|
" { \"int\" \"bits_per_rgb\" } ;"
|
||||||
|
}
|
||||||
|
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||||
|
$nl
|
||||||
|
"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "c-unions" "C unions"
|
||||||
|
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
||||||
|
{ $subsection POSTPONE: C-UNION: }
|
||||||
|
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||||
|
$nl
|
||||||
|
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
|
||||||
|
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
|
||||||
|
{ $subsection alien-signed-1 }
|
||||||
|
{ $subsection alien-unsigned-1 }
|
||||||
|
{ $subsection alien-signed-2 }
|
||||||
|
{ $subsection alien-unsigned-2 }
|
||||||
|
{ $subsection alien-signed-4 }
|
||||||
|
{ $subsection alien-unsigned-4 }
|
||||||
|
{ $subsection alien-signed-cell }
|
||||||
|
{ $subsection alien-unsigned-cell }
|
||||||
|
{ $subsection alien-signed-8 }
|
||||||
|
{ $subsection alien-unsigned-8 }
|
||||||
|
{ $subsection alien-float }
|
||||||
|
{ $subsection alien-double }
|
||||||
|
"Factor numbers can also be converted to C values and stored to memory:"
|
||||||
|
{ $subsection set-alien-signed-1 }
|
||||||
|
{ $subsection set-alien-unsigned-1 }
|
||||||
|
{ $subsection set-alien-signed-2 }
|
||||||
|
{ $subsection set-alien-unsigned-2 }
|
||||||
|
{ $subsection set-alien-signed-4 }
|
||||||
|
{ $subsection set-alien-unsigned-4 }
|
||||||
|
{ $subsection set-alien-signed-cell }
|
||||||
|
{ $subsection set-alien-unsigned-cell }
|
||||||
|
{ $subsection set-alien-signed-8 }
|
||||||
|
{ $subsection set-alien-unsigned-8 }
|
||||||
|
{ $subsection set-alien-float }
|
||||||
|
{ $subsection set-alien-double } ;
|
||||||
|
|
||||||
|
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:"
|
||||||
|
{ $subsection add-library }
|
||||||
|
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||||
|
{ $subsection load-library } ;
|
||||||
|
|
||||||
|
ARTICLE: "alien-invoke" "Calling C from Factor"
|
||||||
|
"The easiest way to call into a C library is to define bindings using a pair of parsing words:"
|
||||||
|
{ $subsection POSTPONE: LIBRARY: }
|
||||||
|
{ $subsection POSTPONE: FUNCTION: }
|
||||||
|
"The above parsing words create word definitions which call a lower-level word; you can use it directly, too:"
|
||||||
|
{ $subsection alien-invoke }
|
||||||
|
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
|
||||||
|
{ $subsection alien-indirect }
|
||||||
|
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||||
|
$nl
|
||||||
|
"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
|
||||||
|
|
||||||
|
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
|
||||||
|
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
|
||||||
|
$nl
|
||||||
|
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
|
||||||
|
{ $code "USE: alien callbacks get clear-hash code-gc" }
|
||||||
|
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
|
||||||
|
|
||||||
|
ARTICLE: "alien-callback" "Calling Factor from C"
|
||||||
|
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
|
||||||
|
{ $subsection alien-callback }
|
||||||
|
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||||
|
{ $subsection "alien-callback-gc" } ;
|
||||||
|
|
||||||
|
ARTICLE: "dll.private" "DLL handles"
|
||||||
|
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
|
||||||
|
$nl
|
||||||
|
"Usually one never has to deal with DLL handles directly; the C library interface creates them as required. However if direct access to these operating system facilities is required, the following primitives can be used:"
|
||||||
|
{ $subsection dlopen }
|
||||||
|
{ $subsection dlsym }
|
||||||
|
{ $subsection dlclose } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-types-specs" "C type specifiers"
|
||||||
|
"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "."
|
||||||
|
$nl
|
||||||
|
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||||
|
{ $table
|
||||||
|
{ "C type" "Notes" }
|
||||||
|
{ { $snippet "char" } "always 1 byte" }
|
||||||
|
{ { $snippet "uchar" } { } }
|
||||||
|
{ { $snippet "short" } "always 2 bytes" }
|
||||||
|
{ { $snippet "ushort" } { } }
|
||||||
|
{ { $snippet "int" } "always 4 bytes" }
|
||||||
|
{ { $snippet "uint" } { } }
|
||||||
|
{ { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
|
||||||
|
{ { $snippet "ulong" } { } }
|
||||||
|
{ { $snippet "longlong" } "always 8 bytes" }
|
||||||
|
{ { $snippet "ulonglong" } { } }
|
||||||
|
{ { $snippet "float" } { } }
|
||||||
|
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
||||||
|
}
|
||||||
|
"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."
|
||||||
|
$nl
|
||||||
|
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "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."
|
||||||
|
$nl
|
||||||
|
"Structure and union types are specified by the name of the structure or union." ;
|
||||||
|
|
||||||
|
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
||||||
|
"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
||||||
|
$nl
|
||||||
|
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
||||||
|
{ $subsection <c-object> }
|
||||||
|
{ $subsection <c-array> }
|
||||||
|
{ $warning
|
||||||
|
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
|
||||||
|
$nl
|
||||||
|
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
|
||||||
|
{ $see-also "c-arrays" } ;
|
||||||
|
|
||||||
|
ARTICLE: "malloc" "Manual memory management"
|
||||||
|
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
|
||||||
|
$nl
|
||||||
|
"Allocating a C datum with a fixed address:"
|
||||||
|
{ $subsection malloc-object }
|
||||||
|
{ $subsection malloc-array }
|
||||||
|
{ $subsection malloc-byte-array }
|
||||||
|
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
|
||||||
|
{ $subsection malloc }
|
||||||
|
{ $subsection calloc }
|
||||||
|
{ $subsection realloc }
|
||||||
|
"The return value of the above three words must always be checked for a memory allocation failure:"
|
||||||
|
{ $subsection check-ptr }
|
||||||
|
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||||
|
{ $subsection free }
|
||||||
|
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||||
|
{ $subsection memcpy }
|
||||||
|
"A wrapper for temporarily allocating a block of memory:"
|
||||||
|
{ $subsection with-malloc } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-strings" "C strings"
|
||||||
|
"The C library interface defines two types of C strings:"
|
||||||
|
{ $table
|
||||||
|
{ "C type" "Notes" }
|
||||||
|
{ { $snippet "char*" } "8-bit per character null-terminated ASCII" }
|
||||||
|
{ { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
|
||||||
|
}
|
||||||
|
"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. 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."
|
||||||
|
"Sometimes a C function has a parameter type of " { $snippet "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:"
|
||||||
|
{ $subsection string>char-alien }
|
||||||
|
{ $subsection string>u16-alien }
|
||||||
|
{ $subsection malloc-char-string }
|
||||||
|
{ $subsection malloc-u16-string }
|
||||||
|
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
|
||||||
|
$nl
|
||||||
|
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
|
||||||
|
{ $subsection alien>char-string }
|
||||||
|
{ $subsection alien>u16-string }
|
||||||
|
{ $subsection memory>string }
|
||||||
|
{ $subsection string>memory } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
||||||
|
"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
|
||||||
|
{ $subsection >c-bool-array }
|
||||||
|
{ $subsection >c-char-array }
|
||||||
|
{ $subsection >c-double-array }
|
||||||
|
{ $subsection >c-float-array }
|
||||||
|
{ $subsection >c-int-array }
|
||||||
|
{ $subsection >c-long-array }
|
||||||
|
{ $subsection >c-longlong-array }
|
||||||
|
{ $subsection >c-short-array }
|
||||||
|
{ $subsection >c-uchar-array }
|
||||||
|
{ $subsection >c-uint-array }
|
||||||
|
{ $subsection >c-ulong-array }
|
||||||
|
{ $subsection >c-ulonglong-array }
|
||||||
|
{ $subsection >c-ushort-array }
|
||||||
|
{ $subsection >c-void*-array }
|
||||||
|
{ $subsection c-bool-array> }
|
||||||
|
{ $subsection c-char*-array> }
|
||||||
|
{ $subsection c-char-array> }
|
||||||
|
{ $subsection c-double-array> }
|
||||||
|
{ $subsection c-float-array> }
|
||||||
|
{ $subsection c-int-array> }
|
||||||
|
{ $subsection c-long-array> }
|
||||||
|
{ $subsection c-longlong-array> }
|
||||||
|
{ $subsection c-short-array> }
|
||||||
|
{ $subsection c-uchar-array> }
|
||||||
|
{ $subsection c-uint-array> }
|
||||||
|
{ $subsection c-ulong-array> }
|
||||||
|
{ $subsection c-ulonglong-array> }
|
||||||
|
{ $subsection c-ushort*-array> }
|
||||||
|
{ $subsection c-ushort-array> }
|
||||||
|
{ $subsection c-void*-array> } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
|
||||||
|
"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
|
||||||
|
{ $subsection char-nth }
|
||||||
|
{ $subsection set-char-nth }
|
||||||
|
{ $subsection uchar-nth }
|
||||||
|
{ $subsection set-uchar-nth }
|
||||||
|
{ $subsection short-nth }
|
||||||
|
{ $subsection set-short-nth }
|
||||||
|
{ $subsection ushort-nth }
|
||||||
|
{ $subsection set-ushort-nth }
|
||||||
|
{ $subsection int-nth }
|
||||||
|
{ $subsection set-int-nth }
|
||||||
|
{ $subsection uint-nth }
|
||||||
|
{ $subsection set-uint-nth }
|
||||||
|
{ $subsection long-nth }
|
||||||
|
{ $subsection set-long-nth }
|
||||||
|
{ $subsection ulong-nth }
|
||||||
|
{ $subsection set-ulong-nth }
|
||||||
|
{ $subsection longlong-nth }
|
||||||
|
{ $subsection set-longlong-nth }
|
||||||
|
{ $subsection ulonglong-nth }
|
||||||
|
{ $subsection set-ulonglong-nth }
|
||||||
|
{ $subsection float-nth }
|
||||||
|
{ $subsection set-float-nth }
|
||||||
|
{ $subsection double-nth }
|
||||||
|
{ $subsection set-double-nth }
|
||||||
|
{ $subsection void*-nth }
|
||||||
|
{ $subsection set-void*-nth }
|
||||||
|
{ $subsection char*-nth }
|
||||||
|
{ $subsection ushort*-nth } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays" "C arrays"
|
||||||
|
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
||||||
|
$nl
|
||||||
|
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
|
||||||
|
{ $subsection "c-arrays-factor" }
|
||||||
|
{ $subsection "c-arrays-get/set" } ;
|
||||||
|
|
||||||
|
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:"
|
||||||
|
{ $subsection <char> }
|
||||||
|
{ $subsection <uchar> }
|
||||||
|
{ $subsection <short> }
|
||||||
|
{ $subsection <ushort> }
|
||||||
|
{ $subsection <int> }
|
||||||
|
{ $subsection <uint> }
|
||||||
|
{ $subsection <long> }
|
||||||
|
{ $subsection <ulong> }
|
||||||
|
{ $subsection <longlong> }
|
||||||
|
{ $subsection <ulonglong> }
|
||||||
|
{ $subsection <float> }
|
||||||
|
{ $subsection <double> }
|
||||||
|
{ $subsection <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:"
|
||||||
|
{ $subsection *char }
|
||||||
|
{ $subsection *uchar }
|
||||||
|
{ $subsection *short }
|
||||||
|
{ $subsection *ushort }
|
||||||
|
{ $subsection *int }
|
||||||
|
{ $subsection *uint }
|
||||||
|
{ $subsection *long }
|
||||||
|
{ $subsection *ulong }
|
||||||
|
{ $subsection *longlong }
|
||||||
|
{ $subsection *ulonglong }
|
||||||
|
{ $subsection *float }
|
||||||
|
{ $subsection *double }
|
||||||
|
{ $subsection *void* }
|
||||||
|
{ $subsection *char* }
|
||||||
|
{ $subsection *ushort* }
|
||||||
|
"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-data" "Passing data between Factor and C"
|
||||||
|
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
||||||
|
{ $subsection "c-types-specs" }
|
||||||
|
{ $subsection "c-byte-arrays" }
|
||||||
|
{ $subsection "malloc" }
|
||||||
|
{ $subsection "c-strings" }
|
||||||
|
{ $subsection "c-arrays" }
|
||||||
|
{ $subsection "c-out-params" }
|
||||||
|
"C-style enumerated types are supported:"
|
||||||
|
{ $subsection POSTPONE: C-ENUM: }
|
||||||
|
"C types can be aliased for convenience and consitency with native library documentation:"
|
||||||
|
{ $subsection POSTPONE: TYPEDEF: }
|
||||||
|
"New C types can be defined:"
|
||||||
|
{ $subsection "c-structs" }
|
||||||
|
{ $subsection "c-unions" }
|
||||||
|
{ $subsection "reading-writing-memory" } ;
|
||||||
|
|
||||||
|
ARTICLE: "embedding-api" "Factor embedding API"
|
||||||
|
"The Factor embedding API is defined in " { $snippet "vm/master.h" } "."
|
||||||
|
$nl
|
||||||
|
"The " { $snippet "F_CHAR" } " type is an alias for the character type used for path names by the operating system; " { $snippet "char" } " on Unix and " { $snippet "wchar_t" } " on Windows."
|
||||||
|
$nl
|
||||||
|
"Including this header file into a C compilation unit will declare the following functions:"
|
||||||
|
{ $table
|
||||||
|
{ {
|
||||||
|
{ $code "void init_factor_from_args("
|
||||||
|
" F_CHAR *image, int argc, F_CHAR **argv, bool embedded"
|
||||||
|
")" }
|
||||||
|
"Initializes Factor."
|
||||||
|
$nl
|
||||||
|
"If " { $snippet "image" } " is " { $snippet "NULL" } ", Factor will load an image file whose name is obtained by suffixing the executable name with " { $snippet ".image" } "."
|
||||||
|
$nl
|
||||||
|
"The " { $snippet "argc" } " and " { $snippet "argv" } " parameters are interpreted just like normal command line arguments when running Factor stand-alone; see " { $link "cli" } "."
|
||||||
|
$nl
|
||||||
|
"The " { $snippet "embedded" } " flag ensures that this function returns as soon as Factor has been initialized. Otherwise, Factor will start up normally."
|
||||||
|
} }
|
||||||
|
{ {
|
||||||
|
{ $code "char *factor_eval_string(char *string)" }
|
||||||
|
"Evaluates a piece of code in the embedded Factor instance by passing the string to " { $link eval>string } " and returning the result. The result must be explicitly freed by a call to " { $snippet "factor_eval_free" } "."
|
||||||
|
} }
|
||||||
|
{ {
|
||||||
|
{ $code "void factor_eval_free(char *result)" }
|
||||||
|
"Frees a string returned by " { $snippet "factor_eval_string()" } "."
|
||||||
|
} }
|
||||||
|
{ {
|
||||||
|
{ $code "void factor_yield(void)" }
|
||||||
|
"Gives all Factor threads a chance to run."
|
||||||
|
} }
|
||||||
|
{ {
|
||||||
|
{ $code "void factor_sleep(long ms)" }
|
||||||
|
"Gives all Factor threads a chance to run for " { $snippet "ms" } " milliseconds."
|
||||||
|
} }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
ARTICLE: "embedding-restrictions" "Embedding API restrictions"
|
||||||
|
"The Factor VM is not thread safe, and does not support multiple instances. There must only be one Factor instance per process, and this instance must be consistently accessed from the same thread for its entire lifetime. Once initialized, a Factor instance cannot be destroyed other than by exiting the process." ;
|
||||||
|
|
||||||
|
ARTICLE: "embedding-factor" "What embedding looks like from Factor"
|
||||||
|
"Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
|
||||||
|
$nl
|
||||||
|
"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly."
|
||||||
|
$nl
|
||||||
|
"There is a word which can detect when Factor is embedded:"
|
||||||
|
{ $subsection embedded? }
|
||||||
|
"No special support is provided for calling out from Factor into the owner process. The C library inteface works fine for this task - see " { $link "alien" } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "embedding" "Embedding Factor into C applications"
|
||||||
|
"The Factor " { $snippet "Makefile" } " builds the Factor VM both as an executable and a library. The library can be used by other applications. File names for the library on various operating systems:"
|
||||||
|
{ $table
|
||||||
|
{ "OS" "Library name" "Shared?" }
|
||||||
|
{ "Windows XP/Vista" { $snippet "factor-nt.dll" } "Yes" }
|
||||||
|
{ "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
|
||||||
|
{ "Mac OS X" { $snippet "libfactor.dylib" } "Yes" }
|
||||||
|
{ "Other Unix" { $snippet "libfactor.a" } "No" }
|
||||||
|
}
|
||||||
|
"An image file must be supplied; a minimal image can be built, however the compiler must be included for the embedding API to work (see " { $link "bootstrap-cli-args" } ")."
|
||||||
|
{ $subsection "embedding-api" }
|
||||||
|
{ $subsection "embedding-factor" }
|
||||||
|
{ $subsection "embedding-restrictions" } ;
|
||||||
|
|
||||||
|
ARTICLE: "alien" "C library interface"
|
||||||
|
"Factor can directly call C functions in native libraries. It is also possible to compile callbacks which run Factor code, and pass them to native libraries as function pointers."
|
||||||
|
$nl
|
||||||
|
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
|
||||||
|
$nl
|
||||||
|
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
|
||||||
|
{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
|
||||||
|
{ $subsection "loading-libs" }
|
||||||
|
{ $subsection "alien-invoke" }
|
||||||
|
{ $subsection "alien-callback" }
|
||||||
|
{ $subsection "c-data" }
|
||||||
|
{ $subsection "dll.private" }
|
||||||
|
{ $subsection "embedding" } ;
|
||||||
|
|
||||||
|
ABOUT: "alien"
|
||||||
|
|
@ -0,0 +1,58 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: alien byte-arrays
|
||||||
|
arrays kernel kernel.private namespaces tools.test sequences
|
||||||
|
libc math system prettyprint ;
|
||||||
|
|
||||||
|
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ 0 <alien> 0 <alien> = ] unit-test
|
||||||
|
[ f ] [ 0 <alien> 1024 <alien> = ] unit-test
|
||||||
|
[ f ] [ "hello" 1024 <alien> = ] unit-test
|
||||||
|
[ f ] [ 0 <alien> ] unit-test
|
||||||
|
[ f ] [ 0 f <displaced-alien> ] unit-test
|
||||||
|
|
||||||
|
! Testing the various bignum accessor
|
||||||
|
10 <byte-array> "dump" set
|
||||||
|
|
||||||
|
[ "dump" get alien-address ] unit-test-fails
|
||||||
|
|
||||||
|
[ 123 ] [
|
||||||
|
123 "dump" get 0 set-alien-signed-1
|
||||||
|
"dump" get 0 alien-signed-1
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 12345 ] [
|
||||||
|
12345 "dump" get 0 set-alien-signed-2
|
||||||
|
"dump" get 0 alien-signed-2
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 12345678 ] [
|
||||||
|
12345678 "dump" get 0 set-alien-signed-4
|
||||||
|
"dump" get 0 alien-signed-4
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 12345678901234567 ] [
|
||||||
|
12345678901234567 "dump" get 0 set-alien-signed-8
|
||||||
|
"dump" get 0 alien-signed-8
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ -1 ] [
|
||||||
|
-1 "dump" get 0 set-alien-signed-8
|
||||||
|
"dump" get 0 alien-signed-8
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
cell 8 = [
|
||||||
|
[ HEX: 123412341234 ] [
|
||||||
|
8 <byte-array>
|
||||||
|
HEX: 123412341234 over 0 set-alien-signed-8
|
||||||
|
0 alien-signed-8
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ HEX: 123412341234 ] [
|
||||||
|
8 <byte-array>
|
||||||
|
HEX: 123412341234 over 0 set-alien-signed-cell
|
||||||
|
0 alien-signed-cell
|
||||||
|
] unit-test
|
||||||
|
] when
|
||||||
|
|
||||||
|
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
|
||||||
|
|
@ -0,0 +1,83 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: alien
|
||||||
|
USING: assocs kernel math namespaces sequences system
|
||||||
|
byte-arrays bit-arrays float-arrays kernel.private tuples ;
|
||||||
|
|
||||||
|
PREDICATE: alien simple-alien
|
||||||
|
underlying-alien not ;
|
||||||
|
|
||||||
|
UNION: simple-c-ptr
|
||||||
|
simple-alien byte-array bit-array float-array POSTPONE: f ;
|
||||||
|
|
||||||
|
UNION: c-ptr
|
||||||
|
alien bit-array byte-array float-array POSTPONE: f ;
|
||||||
|
|
||||||
|
M: f expired? drop t ;
|
||||||
|
|
||||||
|
: <alien> ( address -- alien )
|
||||||
|
f <displaced-alien> { simple-c-ptr } declare ; inline
|
||||||
|
|
||||||
|
: alien>native-string ( alien -- string )
|
||||||
|
windows? [ alien>u16-string ] [ alien>char-string ] if ;
|
||||||
|
|
||||||
|
: dll-path ( dll -- string )
|
||||||
|
(dll-path) alien>native-string ;
|
||||||
|
|
||||||
|
M: alien equal?
|
||||||
|
over alien? [
|
||||||
|
2dup [ expired? ] either? [
|
||||||
|
[ expired? ] both?
|
||||||
|
] [
|
||||||
|
[ alien-address ] 2apply =
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
SYMBOL: libraries
|
||||||
|
|
||||||
|
global [
|
||||||
|
libraries [ H{ } assoc-like ] change
|
||||||
|
] bind
|
||||||
|
|
||||||
|
TUPLE: library path abi dll ;
|
||||||
|
|
||||||
|
: library ( name -- library ) libraries get at ;
|
||||||
|
|
||||||
|
: <library> ( path abi -- library ) f \ library construct-boa ;
|
||||||
|
|
||||||
|
: load-library ( name -- dll )
|
||||||
|
library dup [
|
||||||
|
dup library-dll [ ] [
|
||||||
|
dup library-path dup [
|
||||||
|
dlopen dup rot set-library-dll
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if
|
||||||
|
] ?if
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: add-library ( name path abi -- )
|
||||||
|
<library> swap libraries get set-at ;
|
||||||
|
|
||||||
|
TUPLE: alien-callback return parameters abi quot xt ;
|
||||||
|
|
||||||
|
TUPLE: alien-callback-error ;
|
||||||
|
|
||||||
|
: alien-callback ( return parameters abi quot -- alien )
|
||||||
|
\ alien-callback-error construct-empty throw ;
|
||||||
|
|
||||||
|
TUPLE: alien-indirect return parameters abi ;
|
||||||
|
|
||||||
|
TUPLE: alien-indirect-error ;
|
||||||
|
|
||||||
|
: alien-indirect ( ... funcptr return parameters abi -- )
|
||||||
|
\ alien-indirect-error construct-empty throw ;
|
||||||
|
|
||||||
|
TUPLE: alien-invoke library function return parameters ;
|
||||||
|
|
||||||
|
TUPLE: alien-invoke-error library symbol ;
|
||||||
|
|
||||||
|
: alien-invoke ( ... return library function parameters -- ... )
|
||||||
|
pick pick \ alien-invoke-error construct-boa throw ;
|
||||||
|
|
@ -0,0 +1,38 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien arrays alien.c-types alien.structs
|
||||||
|
sequences math kernel generator.registers
|
||||||
|
namespaces libc ;
|
||||||
|
IN: alien.arrays
|
||||||
|
|
||||||
|
UNION: value-type array struct-type ;
|
||||||
|
|
||||||
|
M: array c-type ;
|
||||||
|
|
||||||
|
M: array heap-size unclip heap-size [ * ] reduce ;
|
||||||
|
|
||||||
|
M: array c-type-align first c-type c-type-align ;
|
||||||
|
|
||||||
|
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: value-type c-type-reg-class drop T{ int-regs } ;
|
||||||
|
|
||||||
|
M: value-type c-type-prep drop f ;
|
||||||
|
|
||||||
|
M: value-type c-type-getter
|
||||||
|
drop [ swap <displaced-alien> ] ;
|
||||||
|
|
||||||
|
M: value-type c-type-setter ( type -- quot )
|
||||||
|
[
|
||||||
|
dup c-type-getter % \ swap , heap-size , \ memcpy ,
|
||||||
|
] [ ] make ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C array support
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,153 @@
|
||||||
|
USING: alien alien.c-types help.syntax help.markup libc
|
||||||
|
kernel.private byte-arrays math strings ;
|
||||||
|
|
||||||
|
HELP: <c-type>
|
||||||
|
{ $values { "type" "a hashtable" } }
|
||||||
|
{ $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 { "type" string } }
|
||||||
|
{ $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" string } { "type" "a hashtable" } }
|
||||||
|
{ $description "Looks up a C type by name." }
|
||||||
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
|
HELP: heap-size
|
||||||
|
{ $values { "type" string } { "size" "an integer" } }
|
||||||
|
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
||||||
|
{ $examples
|
||||||
|
"On a 32-bit system, you will get the following output:"
|
||||||
|
{ $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
|
||||||
|
}
|
||||||
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
|
HELP: stack-size
|
||||||
|
{ $values { "type" string } { "size" "an 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-getter
|
||||||
|
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( 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" string } { "quot" "a quotation with stack effect " { $snippet "( 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: <c-array>
|
||||||
|
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
|
||||||
|
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
|
||||||
|
{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
|
||||||
|
|
||||||
|
{ <c-array> malloc-array } related-words
|
||||||
|
|
||||||
|
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: string>char-alien ( string -- array )
|
||||||
|
{ $values { "string" string } { "array" byte-array } }
|
||||||
|
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
|
||||||
|
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
|
||||||
|
|
||||||
|
{ string>char-alien alien>char-string malloc-char-string } related-words
|
||||||
|
|
||||||
|
HELP: alien>char-string ( c-ptr -- string )
|
||||||
|
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||||
|
{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
|
||||||
|
|
||||||
|
HELP: string>u16-alien ( string -- array )
|
||||||
|
{ $values { "string" string } { "array" byte-array } }
|
||||||
|
{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
|
||||||
|
{ $errors "Throws an error if the string contains null characters." } ;
|
||||||
|
|
||||||
|
{ string>u16-alien alien>u16-string malloc-u16-string } related-words
|
||||||
|
|
||||||
|
HELP: alien>u16-string ( c-ptr -- string )
|
||||||
|
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||||
|
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
|
||||||
|
|
||||||
|
HELP: memory>string ( base len -- string )
|
||||||
|
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
||||||
|
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new Factor string." } ;
|
||||||
|
|
||||||
|
HELP: string>memory ( string base -- )
|
||||||
|
{ $values { "string" string } { "base" c-ptr } }
|
||||||
|
{ $description "Writes the string 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" } { "alien" alien } }
|
||||||
|
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values 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, if the requested size is negative, 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." } ;
|
||||||
|
|
||||||
|
HELP: malloc-char-string
|
||||||
|
{ $values { "string" string } { "alien" c-ptr } }
|
||||||
|
{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
|
||||||
|
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||||
|
{ $errors "Throws an error if memory allocation fails." } ;
|
||||||
|
|
||||||
|
HELP: malloc-u16-string
|
||||||
|
{ $values { "string" string } { "alien" c-ptr } }
|
||||||
|
{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
|
||||||
|
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||||
|
{ $errors "Throws an error if memory allocation fails." } ;
|
||||||
|
|
||||||
|
HELP: define-nth
|
||||||
|
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||||
|
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
|
||||||
|
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||||
|
|
||||||
|
HELP: define-set-nth
|
||||||
|
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||||
|
{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
|
||||||
|
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||||
|
|
||||||
|
HELP: box-parameter
|
||||||
|
{ $values { "n" integer } { "ctype" string } }
|
||||||
|
{ $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 { "ctype" string } }
|
||||||
|
{ $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 { "ctype" string } }
|
||||||
|
{ $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 { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||||
|
{ $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 { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||||
|
{ $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." } ;
|
||||||
|
|
@ -0,0 +1,70 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||||
|
sequences system libc ;
|
||||||
|
|
||||||
|
[ "\u00ff" ]
|
||||||
|
[ "\u00ff" string>char-alien alien>char-string ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ "hello world" ]
|
||||||
|
[ "hello world" string>char-alien alien>char-string ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ "hello\uabcdworld" ]
|
||||||
|
[ "hello\uabcdworld" string>u16-alien alien>u16-string ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ t ] [ f expired? ] unit-test
|
||||||
|
|
||||||
|
[ "hello world" ] [
|
||||||
|
"hello world" malloc-char-string
|
||||||
|
dup alien>char-string swap free
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ "hello world" ] [
|
||||||
|
"hello world" malloc-u16-string
|
||||||
|
dup alien>u16-string swap free
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
||||||
|
|
||||||
|
[ 123 ] [ foo ] unit-test
|
||||||
|
|
||||||
|
[ -1 ] [ -1 <char> *char ] unit-test
|
||||||
|
[ -1 ] [ -1 <short> *short ] unit-test
|
||||||
|
[ -1 ] [ -1 <int> *int ] unit-test
|
||||||
|
|
||||||
|
C-UNION: foo
|
||||||
|
"int"
|
||||||
|
"int" ;
|
||||||
|
|
||||||
|
[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
|
||||||
|
[ t ] [ "char**" 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*" c-type eq? ] unit-test
|
||||||
|
|
||||||
|
TYPEDEF: char MyChar
|
||||||
|
|
||||||
|
[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
|
||||||
|
[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
|
||||||
|
[ t ] [ "char*" c-type "MyChar*" 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*" c-type eq? ] unit-test
|
||||||
|
|
||||||
|
TYPEDEF: int* MyIntArray
|
||||||
|
|
||||||
|
[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test
|
||||||
|
|
||||||
|
TYPEDEF: uchar* MyLPBYTE
|
||||||
|
|
||||||
|
[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
|
||||||
|
|
@ -0,0 +1,356 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: byte-arrays arrays generator.registers assocs
|
||||||
|
kernel kernel.private libc math namespaces parser sequences
|
||||||
|
strings words assocs splitting math.parser cpu.architecture
|
||||||
|
alien quotations system ;
|
||||||
|
IN: alien.c-types
|
||||||
|
|
||||||
|
TUPLE: c-type
|
||||||
|
boxer prep unboxer
|
||||||
|
getter setter
|
||||||
|
reg-class size align stack-align? ;
|
||||||
|
|
||||||
|
: <c-type> ( -- type )
|
||||||
|
T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
|
||||||
|
|
||||||
|
SYMBOL: c-types
|
||||||
|
|
||||||
|
global [
|
||||||
|
c-types [ H{ } assoc-like ] change
|
||||||
|
] bind
|
||||||
|
|
||||||
|
TUPLE: no-c-type name ;
|
||||||
|
|
||||||
|
: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
|
||||||
|
|
||||||
|
: (c-type) ( name -- type/f )
|
||||||
|
c-types get-global at dup [
|
||||||
|
dup string? [ (c-type) ] when
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
GENERIC: c-type ( name -- type )
|
||||||
|
|
||||||
|
: resolve-pointer-type ( name -- name )
|
||||||
|
c-types get at dup string?
|
||||||
|
[ "*" append ] [ drop "void*" ] if
|
||||||
|
c-type ;
|
||||||
|
|
||||||
|
: resolve-typedef ( name -- type )
|
||||||
|
dup string? [ c-type ] when ;
|
||||||
|
|
||||||
|
: parse-array-type ( name -- array )
|
||||||
|
"[" split unclip
|
||||||
|
>r [ "]" ?tail drop string>number ] map r> add* ;
|
||||||
|
|
||||||
|
M: string c-type ( name -- type )
|
||||||
|
CHAR: ] over member? [
|
||||||
|
parse-array-type
|
||||||
|
] [
|
||||||
|
dup c-types get at [
|
||||||
|
resolve-typedef
|
||||||
|
] [
|
||||||
|
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
|
||||||
|
] ?if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: c-type-box ( n type -- )
|
||||||
|
dup c-type-reg-class
|
||||||
|
swap c-type-boxer [ "No boxer" throw ] unless*
|
||||||
|
%box ;
|
||||||
|
|
||||||
|
: c-type-unbox ( n ctype -- )
|
||||||
|
dup c-type-reg-class
|
||||||
|
swap c-type-unboxer [ "No unboxer" throw ] unless*
|
||||||
|
%unbox ;
|
||||||
|
|
||||||
|
M: string c-type-align c-type c-type-align ;
|
||||||
|
|
||||||
|
M: string c-type-stack-align? c-type c-type-stack-align? ;
|
||||||
|
|
||||||
|
GENERIC: box-parameter ( n ctype -- )
|
||||||
|
|
||||||
|
M: c-type box-parameter c-type-box ;
|
||||||
|
|
||||||
|
M: string box-parameter c-type box-parameter ;
|
||||||
|
|
||||||
|
GENERIC: box-return ( ctype -- )
|
||||||
|
|
||||||
|
M: c-type box-return f swap c-type-box ;
|
||||||
|
|
||||||
|
M: string box-return c-type box-return ;
|
||||||
|
|
||||||
|
GENERIC: unbox-parameter ( n ctype -- )
|
||||||
|
|
||||||
|
M: c-type unbox-parameter c-type-unbox ;
|
||||||
|
|
||||||
|
M: string unbox-parameter c-type unbox-parameter ;
|
||||||
|
|
||||||
|
GENERIC: unbox-return ( ctype -- )
|
||||||
|
|
||||||
|
M: c-type unbox-return f swap c-type-unbox ;
|
||||||
|
|
||||||
|
M: string unbox-return c-type unbox-return ;
|
||||||
|
|
||||||
|
! 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: heap-size ( type -- size ) foldable
|
||||||
|
|
||||||
|
M: string heap-size c-type heap-size ;
|
||||||
|
|
||||||
|
M: c-type heap-size c-type-size ;
|
||||||
|
|
||||||
|
GENERIC: stack-size ( type -- size ) foldable
|
||||||
|
|
||||||
|
M: string stack-size c-type stack-size ;
|
||||||
|
|
||||||
|
M: c-type stack-size c-type-size ;
|
||||||
|
|
||||||
|
: c-getter ( name -- quot )
|
||||||
|
c-type c-type-getter [
|
||||||
|
[ "Cannot read struct fields with type" throw ]
|
||||||
|
] unless* ;
|
||||||
|
|
||||||
|
: c-setter ( name -- quot )
|
||||||
|
c-type c-type-setter [
|
||||||
|
[ "Cannot write struct fields with type" throw ]
|
||||||
|
] unless* ;
|
||||||
|
|
||||||
|
: <c-array> ( n type -- array )
|
||||||
|
heap-size * <byte-array> ; inline
|
||||||
|
|
||||||
|
: <c-object> ( type -- array )
|
||||||
|
1 swap <c-array> ; inline
|
||||||
|
|
||||||
|
: malloc-array ( n type -- alien )
|
||||||
|
heap-size calloc ; inline
|
||||||
|
|
||||||
|
: malloc-object ( type -- alien )
|
||||||
|
1 swap malloc-array ; inline
|
||||||
|
|
||||||
|
: malloc-byte-array ( byte-array -- alien )
|
||||||
|
dup length dup malloc [ -rot memcpy ] keep ;
|
||||||
|
|
||||||
|
: malloc-char-string ( string -- alien )
|
||||||
|
string>char-alien malloc-byte-array ;
|
||||||
|
|
||||||
|
: malloc-u16-string ( string -- alien )
|
||||||
|
string>u16-alien malloc-byte-array ;
|
||||||
|
|
||||||
|
: (define-nth) ( word type quot -- )
|
||||||
|
>r heap-size [ rot * ] swap add* r> append define-inline ;
|
||||||
|
|
||||||
|
: nth-word ( name vocab -- word )
|
||||||
|
>r "-nth" append r> create ;
|
||||||
|
|
||||||
|
: define-nth ( name vocab -- )
|
||||||
|
dupd nth-word swap dup c-getter (define-nth) ;
|
||||||
|
|
||||||
|
: set-nth-word ( name vocab -- word )
|
||||||
|
>r "set-" swap "-nth" 3append r> create ;
|
||||||
|
|
||||||
|
: define-set-nth ( name vocab -- )
|
||||||
|
dupd set-nth-word swap dup c-setter (define-nth) ;
|
||||||
|
|
||||||
|
: typedef ( old new -- ) c-types get set-at ;
|
||||||
|
|
||||||
|
: define-c-type ( type name vocab -- )
|
||||||
|
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
|
||||||
|
|
||||||
|
TUPLE: long-long-type ;
|
||||||
|
|
||||||
|
: <long-long-type> ( type -- type )
|
||||||
|
long-long-type construct-delegate ;
|
||||||
|
|
||||||
|
M: long-long-type unbox-parameter ( n type -- )
|
||||||
|
c-type-unboxer %unbox-long-long ;
|
||||||
|
|
||||||
|
M: long-long-type unbox-return ( type -- )
|
||||||
|
f swap unbox-parameter ;
|
||||||
|
|
||||||
|
M: long-long-type box-parameter ( n type -- )
|
||||||
|
c-type-boxer %box-long-long ;
|
||||||
|
|
||||||
|
M: long-long-type box-return ( type -- )
|
||||||
|
f swap box-parameter ;
|
||||||
|
|
||||||
|
: define-deref ( name vocab -- )
|
||||||
|
>r dup CHAR: * add* r> create
|
||||||
|
swap c-getter 0 add* define-inline ;
|
||||||
|
|
||||||
|
: define-out ( name vocab -- )
|
||||||
|
over [ <c-object> tuck 0 ] over c-setter append swap
|
||||||
|
>r >r constructor-word r> r> add* define-inline ;
|
||||||
|
|
||||||
|
: >c-array ( seq type word -- )
|
||||||
|
>r >r dup length dup r> <c-array> dup -roll r>
|
||||||
|
[ execute ] 2curry 2each ; inline
|
||||||
|
|
||||||
|
: >c-array-quot ( type vocab -- quot )
|
||||||
|
dupd set-nth-word [ >c-array ] 2curry ;
|
||||||
|
|
||||||
|
: to-array-word ( name vocab -- word )
|
||||||
|
>r ">c-" swap "-array" 3append r> create ;
|
||||||
|
|
||||||
|
: define-to-array ( type vocab -- )
|
||||||
|
[ to-array-word ] 2keep >c-array-quot define-compound ;
|
||||||
|
|
||||||
|
: c-array>quot ( type vocab -- quot )
|
||||||
|
[
|
||||||
|
\ swap ,
|
||||||
|
nth-word 1quotation ,
|
||||||
|
[ curry map ] %
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: from-array-word ( name vocab -- word )
|
||||||
|
>r "c-" swap "-array>" 3append r> create ;
|
||||||
|
|
||||||
|
: define-from-array ( type vocab -- )
|
||||||
|
[ from-array-word ] 2keep c-array>quot define-compound ;
|
||||||
|
|
||||||
|
: <primitive-type> ( getter setter width boxer unboxer -- type )
|
||||||
|
<c-type>
|
||||||
|
[ set-c-type-unboxer ] keep
|
||||||
|
[ set-c-type-boxer ] keep
|
||||||
|
[ set-c-type-size ] 2keep
|
||||||
|
[ set-c-type-align ] keep
|
||||||
|
[ set-c-type-setter ] keep
|
||||||
|
[ set-c-type-getter ] keep ;
|
||||||
|
|
||||||
|
: define-primitive-type ( type name -- )
|
||||||
|
"alien.c-types"
|
||||||
|
[ define-c-type ] 2keep
|
||||||
|
[ define-deref ] 2keep
|
||||||
|
[ define-to-array ] 2keep
|
||||||
|
[ define-from-array ] 2keep
|
||||||
|
define-out ;
|
||||||
|
|
||||||
|
: expand-constants ( c-type -- c-type' )
|
||||||
|
dup array? [
|
||||||
|
unclip >r [ dup word? [ execute ] when ] map r> add*
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
[ alien-cell ]
|
||||||
|
[ set-alien-cell ]
|
||||||
|
bootstrap-cell
|
||||||
|
"box_alien"
|
||||||
|
"alien_offset" <primitive-type>
|
||||||
|
"void*" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-signed-8 ]
|
||||||
|
[ set-alien-signed-8 ]
|
||||||
|
8
|
||||||
|
"box_signed_8"
|
||||||
|
"to_signed_8" <primitive-type> <long-long-type>
|
||||||
|
"longlong" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-8 ]
|
||||||
|
[ set-alien-unsigned-8 ]
|
||||||
|
8
|
||||||
|
"box_unsigned_8"
|
||||||
|
"to_unsigned_8" <primitive-type> <long-long-type>
|
||||||
|
"ulonglong" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-signed-cell ]
|
||||||
|
[ set-alien-signed-cell ]
|
||||||
|
bootstrap-cell
|
||||||
|
"box_signed_cell"
|
||||||
|
"to_fixnum" <primitive-type>
|
||||||
|
"long" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-cell ]
|
||||||
|
[ set-alien-unsigned-cell ]
|
||||||
|
bootstrap-cell
|
||||||
|
"box_unsigned_cell"
|
||||||
|
"to_cell" <primitive-type>
|
||||||
|
"ulong" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-signed-4 ]
|
||||||
|
[ set-alien-signed-4 ]
|
||||||
|
4
|
||||||
|
"box_signed_4"
|
||||||
|
"to_fixnum" <primitive-type>
|
||||||
|
"int" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-4 ]
|
||||||
|
[ set-alien-unsigned-4 ]
|
||||||
|
4
|
||||||
|
"box_unsigned_4"
|
||||||
|
"to_cell" <primitive-type>
|
||||||
|
"uint" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-signed-2 ]
|
||||||
|
[ set-alien-signed-2 ]
|
||||||
|
2
|
||||||
|
"box_signed_2"
|
||||||
|
"to_fixnum" <primitive-type>
|
||||||
|
"short" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-2 ]
|
||||||
|
[ set-alien-unsigned-2 ]
|
||||||
|
2
|
||||||
|
"box_unsigned_2"
|
||||||
|
"to_cell" <primitive-type>
|
||||||
|
"ushort" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-signed-1 ]
|
||||||
|
[ set-alien-signed-1 ]
|
||||||
|
1
|
||||||
|
"box_signed_1"
|
||||||
|
"to_fixnum" <primitive-type>
|
||||||
|
"char" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-1 ]
|
||||||
|
[ set-alien-unsigned-1 ]
|
||||||
|
1
|
||||||
|
"box_unsigned_1"
|
||||||
|
"to_cell" <primitive-type>
|
||||||
|
"uchar" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-unsigned-4 zero? not ]
|
||||||
|
[ 1 0 ? set-alien-unsigned-4 ]
|
||||||
|
4
|
||||||
|
"box_boolean"
|
||||||
|
"to_boolean" <primitive-type>
|
||||||
|
"bool" define-primitive-type
|
||||||
|
|
||||||
|
[ alien-float ]
|
||||||
|
[ >r >r >float r> r> set-alien-float ]
|
||||||
|
4
|
||||||
|
"box_float"
|
||||||
|
"to_float" <primitive-type>
|
||||||
|
"float" define-primitive-type
|
||||||
|
|
||||||
|
T{ float-regs f 4 } "float" c-type set-c-type-reg-class
|
||||||
|
[ >float ] "float" c-type set-c-type-prep
|
||||||
|
|
||||||
|
[ alien-double ]
|
||||||
|
[ >r >r >float r> r> set-alien-double ]
|
||||||
|
8
|
||||||
|
"box_double"
|
||||||
|
"to_double" <primitive-type>
|
||||||
|
"double" define-primitive-type
|
||||||
|
|
||||||
|
T{ float-regs f 8 } "double" c-type set-c-type-reg-class
|
||||||
|
[ >float ] "double" c-type set-c-type-prep
|
||||||
|
|
||||||
|
[ alien-cell alien>char-string ]
|
||||||
|
[ set-alien-cell ]
|
||||||
|
bootstrap-cell
|
||||||
|
"box_char_string"
|
||||||
|
"alien_offset" <primitive-type>
|
||||||
|
"char*" define-primitive-type
|
||||||
|
|
||||||
|
"char*" "uchar*" typedef
|
||||||
|
|
||||||
|
[ string>char-alien ] "char*" c-type set-c-type-prep
|
||||||
|
|
||||||
|
[ alien-cell alien>u16-string ]
|
||||||
|
[ set-alien-cell ]
|
||||||
|
4
|
||||||
|
"box_u16_string"
|
||||||
|
"alien_offset" <primitive-type>
|
||||||
|
"ushort*" define-primitive-type
|
||||||
|
|
||||||
|
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C data type support
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,366 @@
|
||||||
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays generator generator.registers generator.fixup
|
||||||
|
hashtables kernel math namespaces sequences words
|
||||||
|
inference.backend inference.dataflow system math.functions
|
||||||
|
math.parser classes alien.arrays alien.c-types alien.structs
|
||||||
|
alien.syntax cpu.architecture alien inspector quotations assocs
|
||||||
|
kernel.private threads continuations.private libc combinators ;
|
||||||
|
IN: alien.compiler
|
||||||
|
|
||||||
|
! Common protocol for alien-invoke/alien-callback/alien-indirect
|
||||||
|
GENERIC: alien-node-parameters ( node -- seq )
|
||||||
|
GENERIC: alien-node-return ( node -- ctype )
|
||||||
|
GENERIC: alien-node-abi ( node -- str )
|
||||||
|
|
||||||
|
: large-struct? ( ctype -- ? )
|
||||||
|
dup c-struct? [
|
||||||
|
heap-size struct-small-enough? not
|
||||||
|
] [
|
||||||
|
drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: alien-node-parameters* ( node -- seq )
|
||||||
|
dup alien-node-parameters
|
||||||
|
swap alien-node-return large-struct? [ "void*" add* ] when ;
|
||||||
|
|
||||||
|
: alien-node-return* ( node -- ctype )
|
||||||
|
alien-node-return dup large-struct? [ drop "void" ] when ;
|
||||||
|
|
||||||
|
: parameter-align ( n type -- n delta )
|
||||||
|
over >r
|
||||||
|
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if
|
||||||
|
align
|
||||||
|
dup r> - ;
|
||||||
|
|
||||||
|
: parameter-sizes ( types -- total offsets )
|
||||||
|
#! Compute stack frame locations.
|
||||||
|
[
|
||||||
|
0 [
|
||||||
|
[ parameter-align drop dup , ] keep stack-size +
|
||||||
|
] reduce cell align
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: return-size ( ctype -- n )
|
||||||
|
#! Amount of space we reserve for a return value.
|
||||||
|
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
||||||
|
|
||||||
|
: alien-stack-frame ( node -- n )
|
||||||
|
alien-node-parameters* parameter-sizes drop ;
|
||||||
|
|
||||||
|
: alien-invoke-frame ( node -- n )
|
||||||
|
#! One cell is temporary storage, temp@
|
||||||
|
dup alien-node-return return-size
|
||||||
|
swap alien-stack-frame +
|
||||||
|
cell + ;
|
||||||
|
|
||||||
|
: set-stack-frame ( n -- )
|
||||||
|
dup [ frame-required ] when* \ stack-frame set ;
|
||||||
|
|
||||||
|
: with-stack-frame ( n quot -- )
|
||||||
|
swap set-stack-frame
|
||||||
|
call
|
||||||
|
f set-stack-frame ; inline
|
||||||
|
|
||||||
|
: reg-class-full? ( class -- ? )
|
||||||
|
dup class get swap param-regs length >= ;
|
||||||
|
|
||||||
|
: spill-param ( reg-class -- n reg-class )
|
||||||
|
reg-size stack-params dup get -rot +@ T{ stack-params } ;
|
||||||
|
|
||||||
|
: fastcall-param ( reg-class -- n reg-class )
|
||||||
|
[ dup class get swap inc-reg-class ] keep ;
|
||||||
|
|
||||||
|
: alloc-parameter ( parameter -- reg reg-class )
|
||||||
|
c-type c-type-reg-class dup reg-class-full?
|
||||||
|
[ spill-param ] [ fastcall-param ] if
|
||||||
|
[ param-reg ] keep ;
|
||||||
|
|
||||||
|
: (flatten-int-type) ( size -- )
|
||||||
|
cell /i "void*" <repetition> % ;
|
||||||
|
|
||||||
|
: flatten-int-type ( n type -- n )
|
||||||
|
[ parameter-align (flatten-int-type) ] keep
|
||||||
|
stack-size cell align dup (flatten-int-type) + ;
|
||||||
|
|
||||||
|
: flatten-value-type ( n type -- n )
|
||||||
|
dup c-type c-type-reg-class T{ int-regs } =
|
||||||
|
[ flatten-int-type ] [ , ] if ;
|
||||||
|
|
||||||
|
: flatten-value-types ( params -- params )
|
||||||
|
#! Convert value type structs to consecutive void*s.
|
||||||
|
[ 0 [ flatten-value-type ] reduce drop ] { } make ;
|
||||||
|
|
||||||
|
: each-parameter ( parameters quot -- )
|
||||||
|
>r [ parameter-sizes nip ] keep r> 2each ; inline
|
||||||
|
|
||||||
|
: reverse-each-parameter ( parameters quot -- )
|
||||||
|
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
|
||||||
|
|
||||||
|
: reset-freg-counts ( -- )
|
||||||
|
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||||
|
|
||||||
|
: with-param-regs ( quot -- )
|
||||||
|
#! In quot you can call alloc-parameter
|
||||||
|
[ reset-freg-counts call ] with-scope ; inline
|
||||||
|
|
||||||
|
: move-parameters ( node word -- )
|
||||||
|
#! Moves values from C stack to registers (if word is
|
||||||
|
#! %load-param-reg) and registers to C stack (if word is
|
||||||
|
#! %save-param-reg).
|
||||||
|
swap
|
||||||
|
alien-node-parameters*
|
||||||
|
flatten-value-types
|
||||||
|
[ pick >r alloc-parameter r> execute ] each-parameter
|
||||||
|
drop ; inline
|
||||||
|
|
||||||
|
: if-void ( type true false -- )
|
||||||
|
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||||
|
|
||||||
|
: alien-invoke-stack ( node extra -- )
|
||||||
|
over alien-node-parameters length + dup reify-curries
|
||||||
|
over consume-values
|
||||||
|
dup alien-node-return "void" = 0 1 ?
|
||||||
|
swap produce-values ;
|
||||||
|
|
||||||
|
: (make-prep-quot) ( parameters -- )
|
||||||
|
dup empty? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
unclip c-type c-type-prep %
|
||||||
|
\ >r , (make-prep-quot) \ r> ,
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: make-prep-quot ( node -- quot )
|
||||||
|
alien-node-parameters
|
||||||
|
[ <reversed> (make-prep-quot) ] [ ] make ;
|
||||||
|
|
||||||
|
: unbox-parameters ( offset node -- )
|
||||||
|
alien-node-parameters [
|
||||||
|
%prepare-unbox >r over + r> unbox-parameter
|
||||||
|
] reverse-each-parameter drop ;
|
||||||
|
|
||||||
|
: prepare-box-struct ( node -- offset )
|
||||||
|
#! Return offset on C stack where to store unboxed
|
||||||
|
#! parameters. If the C function is returning a structure,
|
||||||
|
#! the first parameter is an implicit target area pointer,
|
||||||
|
#! so we need to use a different offset.
|
||||||
|
alien-node-return dup large-struct?
|
||||||
|
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
|
||||||
|
|
||||||
|
: objects>registers ( node -- )
|
||||||
|
#! Generate code for unboxing a list of C types, then
|
||||||
|
#! generate code for moving these parameters to register on
|
||||||
|
#! architectures where parameters are passed in registers.
|
||||||
|
[
|
||||||
|
[ prepare-box-struct ] keep
|
||||||
|
[ unbox-parameters ] keep
|
||||||
|
\ %load-param-reg move-parameters
|
||||||
|
] with-param-regs ;
|
||||||
|
|
||||||
|
: box-return* ( node -- )
|
||||||
|
alien-node-return [ ] [ box-return ] if-void ;
|
||||||
|
|
||||||
|
M: alien-invoke alien-node-parameters alien-invoke-parameters ;
|
||||||
|
M: alien-invoke alien-node-return alien-invoke-return ;
|
||||||
|
|
||||||
|
M: alien-invoke alien-node-abi
|
||||||
|
alien-invoke-library library
|
||||||
|
[ library-abi ] [ "cdecl" ] if* ;
|
||||||
|
|
||||||
|
: stdcall-mangle ( symbol node -- symbol )
|
||||||
|
"@"
|
||||||
|
swap alien-node-parameters parameter-sizes drop
|
||||||
|
number>string 3append ;
|
||||||
|
|
||||||
|
: (alien-invoke-dlsym) ( node -- symbol dll )
|
||||||
|
dup alien-invoke-function
|
||||||
|
swap alien-invoke-library load-library ;
|
||||||
|
|
||||||
|
TUPLE: no-such-symbol ;
|
||||||
|
|
||||||
|
M: no-such-symbol summary
|
||||||
|
drop "Symbol not found" ;
|
||||||
|
|
||||||
|
: no-such-symbol ( -- )
|
||||||
|
\ no-such-symbol inference-error ;
|
||||||
|
|
||||||
|
: alien-invoke-dlsym ( node -- symbol dll )
|
||||||
|
dup (alien-invoke-dlsym) 2dup dlsym [
|
||||||
|
>r over stdcall-mangle r> 2dup dlsym
|
||||||
|
[ no-such-symbol ] unless
|
||||||
|
] unless rot drop ;
|
||||||
|
|
||||||
|
M: alien-invoke-error summary
|
||||||
|
drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
|
||||||
|
|
||||||
|
: pop-parameters pop-literal nip [ expand-constants ] map ;
|
||||||
|
|
||||||
|
\ alien-invoke [
|
||||||
|
! Four literals
|
||||||
|
4 ensure-values
|
||||||
|
\ alien-invoke empty-node
|
||||||
|
! Compile-time parameters
|
||||||
|
pop-parameters over set-alien-invoke-parameters
|
||||||
|
pop-literal nip over set-alien-invoke-function
|
||||||
|
pop-literal nip over set-alien-invoke-library
|
||||||
|
pop-literal nip over set-alien-invoke-return
|
||||||
|
! Quotation which coerces parameters to required types
|
||||||
|
dup make-prep-quot infer-quot
|
||||||
|
! If symbol doesn't resolve, no stack effect, no compile
|
||||||
|
dup alien-invoke-dlsym 2drop
|
||||||
|
! Add node to IR
|
||||||
|
dup node,
|
||||||
|
! Magic #: consume exactly the number of inputs
|
||||||
|
0 alien-invoke-stack
|
||||||
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
M: alien-invoke generate-node
|
||||||
|
dup alien-invoke-frame [
|
||||||
|
end-basic-block
|
||||||
|
%prepare-alien-invoke
|
||||||
|
dup objects>registers
|
||||||
|
dup alien-invoke-dlsym %alien-invoke
|
||||||
|
dup %cleanup
|
||||||
|
box-return*
|
||||||
|
iterate-next
|
||||||
|
] with-stack-frame ;
|
||||||
|
|
||||||
|
M: alien-indirect alien-node-parameters alien-indirect-parameters ;
|
||||||
|
M: alien-indirect alien-node-return alien-indirect-return ;
|
||||||
|
M: alien-indirect alien-node-abi alien-indirect-abi ;
|
||||||
|
|
||||||
|
M: alien-indirect-error summary
|
||||||
|
drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ;
|
||||||
|
|
||||||
|
\ alien-indirect [
|
||||||
|
! Three literals and function pointer
|
||||||
|
4 ensure-values
|
||||||
|
4 reify-curries
|
||||||
|
\ alien-indirect empty-node
|
||||||
|
! Compile-time parameters
|
||||||
|
pop-literal nip over set-alien-indirect-abi
|
||||||
|
pop-parameters over set-alien-indirect-parameters
|
||||||
|
pop-literal nip over set-alien-indirect-return
|
||||||
|
! Quotation which coerces parameters to required types
|
||||||
|
dup make-prep-quot 1 make-dip infer-quot
|
||||||
|
! Add node to IR
|
||||||
|
dup node,
|
||||||
|
! Magic #: consume the function pointer, too
|
||||||
|
1 alien-invoke-stack
|
||||||
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
M: alien-indirect generate-node
|
||||||
|
dup alien-invoke-frame [
|
||||||
|
! Flush registers
|
||||||
|
end-basic-block
|
||||||
|
! Save registers for GC
|
||||||
|
%prepare-alien-invoke
|
||||||
|
! Save alien at top of stack to temporary storage
|
||||||
|
%prepare-alien-indirect
|
||||||
|
dup objects>registers
|
||||||
|
! Call alien in temporary storage
|
||||||
|
%alien-indirect
|
||||||
|
dup %cleanup
|
||||||
|
box-return*
|
||||||
|
iterate-next
|
||||||
|
] with-stack-frame ;
|
||||||
|
|
||||||
|
! Callbacks are registered in a global hashtable. If you clear
|
||||||
|
! this hashtable, they will all be blown away by code GC, beware
|
||||||
|
SYMBOL: callbacks
|
||||||
|
|
||||||
|
H{ } clone callbacks set-global
|
||||||
|
|
||||||
|
: register-callback ( word -- ) dup callbacks get set-at ;
|
||||||
|
|
||||||
|
M: alien-callback alien-node-parameters alien-callback-parameters ;
|
||||||
|
M: alien-callback alien-node-return alien-callback-return ;
|
||||||
|
M: alien-callback alien-node-abi alien-callback-abi ;
|
||||||
|
|
||||||
|
M: alien-callback-error summary
|
||||||
|
drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
|
||||||
|
|
||||||
|
: callback-bottom ( node -- )
|
||||||
|
alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
|
||||||
|
|
||||||
|
\ alien-callback [
|
||||||
|
4 ensure-values
|
||||||
|
\ alien-callback empty-node dup node,
|
||||||
|
pop-literal nip over set-alien-callback-quot
|
||||||
|
pop-literal nip over set-alien-callback-abi
|
||||||
|
pop-parameters over set-alien-callback-parameters
|
||||||
|
pop-literal nip over set-alien-callback-return
|
||||||
|
gensym dup register-callback over set-alien-callback-xt
|
||||||
|
callback-bottom
|
||||||
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
: box-parameters ( node -- )
|
||||||
|
alien-node-parameters* [ box-parameter ] each-parameter ;
|
||||||
|
|
||||||
|
: registers>objects ( node -- )
|
||||||
|
[
|
||||||
|
dup \ %save-param-reg move-parameters
|
||||||
|
"nest_stacks" f %alien-invoke
|
||||||
|
box-parameters
|
||||||
|
] with-param-regs ;
|
||||||
|
|
||||||
|
TUPLE: callback-context ;
|
||||||
|
|
||||||
|
: current-callback 2 getenv ;
|
||||||
|
|
||||||
|
: wait-to-return ( token -- )
|
||||||
|
dup current-callback eq? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
yield wait-to-return
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: do-callback ( quot token -- )
|
||||||
|
init-error-handler
|
||||||
|
dup 2 setenv
|
||||||
|
slip
|
||||||
|
wait-to-return ; inline
|
||||||
|
|
||||||
|
: prepare-callback-return ( ctype -- quot )
|
||||||
|
alien-node-return {
|
||||||
|
{ [ dup "void" = ] [ drop [ ] ] }
|
||||||
|
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||||
|
{ [ t ] [ c-type c-type-prep ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: wrap-callback-quot ( node -- quot )
|
||||||
|
[
|
||||||
|
dup alien-callback-quot
|
||||||
|
swap prepare-callback-return append ,
|
||||||
|
[ callback-context construct-empty do-callback ] %
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||||
|
|
||||||
|
: callback-unwind ( node -- n )
|
||||||
|
{
|
||||||
|
{ [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
|
||||||
|
{ [ dup alien-node-return large-struct? ] [ drop 4 ] }
|
||||||
|
{ [ t ] [ drop 0 ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: %callback-return ( node -- )
|
||||||
|
#! All the extra book-keeping for %unwind is only for x86.
|
||||||
|
#! On other platforms its an alias for %return.
|
||||||
|
dup alien-node-return*
|
||||||
|
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||||
|
callback-unwind %unwind ;
|
||||||
|
|
||||||
|
: generate-callback ( node -- )
|
||||||
|
dup alien-callback-xt dup rot [
|
||||||
|
dup alien-stack-frame [
|
||||||
|
init-templates
|
||||||
|
dup registers>objects
|
||||||
|
dup wrap-callback-quot %alien-callback
|
||||||
|
%callback-return
|
||||||
|
] with-stack-frame
|
||||||
|
] generate-1 ;
|
||||||
|
|
||||||
|
M: alien-callback generate-node
|
||||||
|
end-basic-block generate-callback iterate-next ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C library interface implementation
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien alien.c-types parser threads words kernel.private
|
||||||
|
kernel ;
|
||||||
|
IN: alien.remote-control
|
||||||
|
|
||||||
|
: eval-callback
|
||||||
|
"void*" { "char*" } "cdecl"
|
||||||
|
[ eval>string malloc-char-string ] alien-callback ;
|
||||||
|
|
||||||
|
: yield-callback
|
||||||
|
"void" { } "cdecl" [ yield ] alien-callback ;
|
||||||
|
|
||||||
|
: sleep-callback
|
||||||
|
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||||
|
|
||||||
|
: ?callback ( word -- alien )
|
||||||
|
dup compiled? [ execute ] [ drop f ] if ; inline
|
||||||
|
|
||||||
|
: init-remote-control ( -- )
|
||||||
|
\ eval-callback ?callback 16 setenv
|
||||||
|
\ yield-callback ?callback 17 setenv
|
||||||
|
\ sleep-callback ?callback 18 setenv ;
|
||||||
|
|
||||||
|
MAIN: init-remote-control
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Support for embedding Factor in other applications
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
USING: alien.structs alien.c-types strings help.markup
|
||||||
|
sequences io arrays ;
|
||||||
|
|
||||||
|
M: string slot-specs c-type struct-type-fields ;
|
||||||
|
|
||||||
|
M: array ($instance) first ($instance) " array" write ;
|
||||||
|
|
@ -0,0 +1,42 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||||
|
sequences system libc words vocabs namespaces ;
|
||||||
|
|
||||||
|
C-STRUCT: bar
|
||||||
|
{ "int" "x" }
|
||||||
|
{ { "int" 8 } "y" } ;
|
||||||
|
|
||||||
|
[ 36 ] [ "bar" heap-size ] unit-test
|
||||||
|
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
|
||||||
|
|
||||||
|
C-STRUCT: align-test
|
||||||
|
{ "int" "x" }
|
||||||
|
{ "double" "y" } ;
|
||||||
|
|
||||||
|
[ 16 ] [ "align-test" heap-size ] unit-test
|
||||||
|
|
||||||
|
cell 4 = [
|
||||||
|
C-STRUCT: one
|
||||||
|
{ "long" "a" } { "double" "b" } { "int" "c" } ;
|
||||||
|
|
||||||
|
[ 24 ] [ "one" heap-size ] unit-test
|
||||||
|
] when
|
||||||
|
|
||||||
|
: MAX_FOOS 30 ;
|
||||||
|
|
||||||
|
C-STRUCT: foox
|
||||||
|
{ { "int" MAX_FOOS } "x" } ;
|
||||||
|
|
||||||
|
[ 120 ] [ "foox" heap-size ] unit-test
|
||||||
|
|
||||||
|
C-UNION: barx
|
||||||
|
{ "int" MAX_FOOS }
|
||||||
|
"float" ;
|
||||||
|
|
||||||
|
[ 120 ] [ "barx" heap-size ] unit-test
|
||||||
|
|
||||||
|
"help" vocab [
|
||||||
|
"help" "help" lookup "help" set
|
||||||
|
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||||
|
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1,99 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays generic hashtables kernel kernel.private math
|
||||||
|
namespaces parser sequences strings words libc slots
|
||||||
|
alien.c-types math.functions math.vectors cpu.architecture ;
|
||||||
|
IN: alien.structs
|
||||||
|
|
||||||
|
: align-offset ( offset type -- offset )
|
||||||
|
c-type c-type-align align ;
|
||||||
|
|
||||||
|
: struct-offsets ( specs -- size )
|
||||||
|
0 [
|
||||||
|
[ slot-spec-type align-offset ] keep
|
||||||
|
[ set-slot-spec-offset ] 2keep
|
||||||
|
slot-spec-type heap-size +
|
||||||
|
] reduce ;
|
||||||
|
|
||||||
|
: define-struct-slot-word ( spec word quot -- )
|
||||||
|
rot slot-spec-offset add* define-inline ;
|
||||||
|
|
||||||
|
: define-getter ( type spec -- )
|
||||||
|
[ set-reader-props ] keep
|
||||||
|
dup slot-spec-reader
|
||||||
|
over slot-spec-type c-getter
|
||||||
|
define-struct-slot-word ;
|
||||||
|
|
||||||
|
: define-setter ( type spec -- )
|
||||||
|
[ set-writer-props ] keep
|
||||||
|
dup slot-spec-writer
|
||||||
|
over slot-spec-type c-setter
|
||||||
|
define-struct-slot-word ;
|
||||||
|
|
||||||
|
: define-field ( type spec -- )
|
||||||
|
2dup define-getter define-setter ;
|
||||||
|
|
||||||
|
: if-value-structs? ( ctype true false -- )
|
||||||
|
value-structs?
|
||||||
|
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
|
||||||
|
|
||||||
|
TUPLE: struct-type size align fields ;
|
||||||
|
|
||||||
|
M: struct-type heap-size struct-type-size ;
|
||||||
|
|
||||||
|
M: struct-type c-type-align struct-type-align ;
|
||||||
|
|
||||||
|
M: struct-type c-type-stack-align? drop f ;
|
||||||
|
|
||||||
|
M: struct-type unbox-parameter
|
||||||
|
[ heap-size %unbox-struct ]
|
||||||
|
[ unbox-parameter ]
|
||||||
|
if-value-structs? ;
|
||||||
|
|
||||||
|
M: struct-type unbox-return
|
||||||
|
f swap heap-size %unbox-struct ;
|
||||||
|
|
||||||
|
M: struct-type box-parameter
|
||||||
|
[ heap-size %box-struct ]
|
||||||
|
[ box-parameter ]
|
||||||
|
if-value-structs? ;
|
||||||
|
|
||||||
|
M: struct-type box-return
|
||||||
|
f swap heap-size %box-struct ;
|
||||||
|
|
||||||
|
M: struct-type stack-size
|
||||||
|
[ heap-size ] [ stack-size ] if-value-structs? ;
|
||||||
|
|
||||||
|
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
||||||
|
|
||||||
|
: (define-struct) ( name vocab size align fields -- )
|
||||||
|
>r [ align ] keep r>
|
||||||
|
struct-type construct-boa
|
||||||
|
-rot define-c-type ;
|
||||||
|
|
||||||
|
: make-field ( struct-name vocab type field-name -- spec )
|
||||||
|
[
|
||||||
|
-rot expand-constants ,
|
||||||
|
over ,
|
||||||
|
3dup reader-word ,
|
||||||
|
writer-word ,
|
||||||
|
] { } make
|
||||||
|
first4 0 -rot <slot-spec> ;
|
||||||
|
|
||||||
|
: define-struct-early ( name vocab fields -- fields )
|
||||||
|
-rot [ rot first2 make-field ] 2curry map ;
|
||||||
|
|
||||||
|
: compute-struct-align ( types -- n )
|
||||||
|
[ c-type-align ] map supremum ;
|
||||||
|
|
||||||
|
: define-struct ( name vocab fields -- )
|
||||||
|
pick >r
|
||||||
|
[ struct-offsets ] keep
|
||||||
|
[ [ slot-spec-type ] map compute-struct-align ] keep
|
||||||
|
[ (define-struct) ] keep
|
||||||
|
r> [ swap define-field ] curry each ;
|
||||||
|
|
||||||
|
: define-union ( name vocab members -- )
|
||||||
|
[ expand-constants ] map
|
||||||
|
[ [ heap-size ] map supremum ] keep
|
||||||
|
compute-struct-align f (define-struct) ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C structure support
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C library interface
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
C library interface parsing words
|
||||||
|
|
@ -0,0 +1,94 @@
|
||||||
|
USING: alien alien.c-types alien.structs alien.syntax
|
||||||
|
alien.syntax.private help.markup help.syntax ;
|
||||||
|
|
||||||
|
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 integer" } }
|
||||||
|
{ $description "Creates an alien object at parse time." }
|
||||||
|
{ $notes "Alien objects are invalidated between image saves and loads." } ;
|
||||||
|
|
||||||
|
ARTICLE: "syntax-aliens" "Alien object literal syntax"
|
||||||
|
{ $subsection POSTPONE: ALIEN: }
|
||||||
|
{ $subsection POSTPONE: DLL" } ;
|
||||||
|
|
||||||
|
HELP: LIBRARY:
|
||||||
|
{ $syntax "LIBRARY: name" }
|
||||||
|
{ $values { "name" "a logical library name" } }
|
||||||
|
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ;
|
||||||
|
|
||||||
|
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_answer compile"
|
||||||
|
"\"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 "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
|
{ $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-STRUCT:
|
||||||
|
{ $syntax "C-STRUCT: name pairs... ;" }
|
||||||
|
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
||||||
|
{ $description "Defines a C struct layout and accessor words." }
|
||||||
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
||||||
|
|
||||||
|
HELP: C-UNION:
|
||||||
|
{ $syntax "C-UNION: name members... ;" }
|
||||||
|
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
||||||
|
{ $description "Defines a new C type sized to fit its largest member." }
|
||||||
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
|
||||||
|
{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ;
|
||||||
|
|
||||||
|
HELP: C-ENUM:
|
||||||
|
{ $syntax "C-ENUM: words... ;" }
|
||||||
|
{ $values { "words" "a sequence of word names" } }
|
||||||
|
{ $description "Creates a sequence of compound 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 symbolic constants instead." }
|
||||||
|
{ $examples
|
||||||
|
"The following two lines are equivalent:"
|
||||||
|
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: typedef
|
||||||
|
{ $values { "old" "a string" } { "new" "a string" } }
|
||||||
|
{ $description "Alises 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." } ;
|
||||||
|
|
||||||
|
{ typedef POSTPONE: TYPEDEF: } related-words
|
||||||
|
|
||||||
|
HELP: c-struct?
|
||||||
|
{ $values { "type" "a string" } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-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." } ;
|
||||||
|
|
@ -0,0 +1,62 @@
|
||||||
|
! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays alien alien.c-types alien.structs kernel math
|
||||||
|
namespaces parser sequences words quotations math.parser
|
||||||
|
splitting effects prettyprint prettyprint.sections
|
||||||
|
prettyprint.backend assocs ;
|
||||||
|
IN: alien.syntax
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: parse-arglist ( return seq -- types effect )
|
||||||
|
2 group dup keys swap values
|
||||||
|
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
|
||||||
|
|
||||||
|
: function-quot ( type lib func types -- quot )
|
||||||
|
[ alien-invoke ] 2curry 2curry ;
|
||||||
|
|
||||||
|
: define-function ( return library function parameters -- )
|
||||||
|
>r pick r> parse-arglist
|
||||||
|
pick create-in dup reset-generic
|
||||||
|
>r >r function-quot r> r>
|
||||||
|
-rot define-declared ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: DLL" skip-blank parse-string dlopen parsed ; parsing
|
||||||
|
|
||||||
|
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||||
|
|
||||||
|
: LIBRARY: scan "c-library" set ; parsing
|
||||||
|
|
||||||
|
: FUNCTION:
|
||||||
|
scan "c-library" get scan ";" parse-tokens
|
||||||
|
[ "()" subseq? not ] subset
|
||||||
|
define-function ; parsing
|
||||||
|
|
||||||
|
: TYPEDEF:
|
||||||
|
scan scan typedef ; parsing
|
||||||
|
|
||||||
|
: C-STRUCT:
|
||||||
|
scan in get
|
||||||
|
parse-definition
|
||||||
|
>r 2dup r> define-struct-early
|
||||||
|
define-struct ; parsing
|
||||||
|
|
||||||
|
: C-UNION:
|
||||||
|
scan in get parse-definition define-union ; parsing
|
||||||
|
|
||||||
|
: C-ENUM:
|
||||||
|
";" parse-tokens
|
||||||
|
dup length
|
||||||
|
[ >r create-in r> 1quotation define-compound ] 2each ;
|
||||||
|
parsing
|
||||||
|
|
||||||
|
M: alien pprint*
|
||||||
|
dup expired? [
|
||||||
|
drop "( alien expired )" text
|
||||||
|
] [
|
||||||
|
\ ALIEN: [ alien-address pprint* ] pprint-prefix
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
M: dll pprint* dll-path dup "DLL\" " pprint-string ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -0,0 +1,70 @@
|
||||||
|
USING: byte-arrays bit-arrays help.markup help.syntax
|
||||||
|
kernel kernel.private prettyprint strings sbufs vectors
|
||||||
|
quotations sequences.private ;
|
||||||
|
IN: arrays
|
||||||
|
|
||||||
|
ARTICLE: "arrays" "Arrays"
|
||||||
|
"Arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } "). The literal syntax is covered in " { $link "syntax-arrays" } ". Resizable arrays also exist and are called vectors; see " { $link "vectors" } "."
|
||||||
|
$nl
|
||||||
|
"Array words are in the " { $vocab-link "arrays" } " vocabulary. Unsafe implementation words are in the " { $vocab-link "sequences.private" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Arrays form a class of objects:"
|
||||||
|
{ $subsection array }
|
||||||
|
{ $subsection array? }
|
||||||
|
"Creating new arrays:"
|
||||||
|
{ $subsection >array }
|
||||||
|
{ $subsection <array> }
|
||||||
|
"Creating an array from several elements on the stack:"
|
||||||
|
{ $subsection 1array }
|
||||||
|
{ $subsection 2array }
|
||||||
|
{ $subsection 3array }
|
||||||
|
{ $subsection 4array }
|
||||||
|
"Arrays can be accessed without bounds checks in a pointer unsafe way."
|
||||||
|
{ $subsection array-nth }
|
||||||
|
{ $subsection set-array-nth }
|
||||||
|
"The class of two-element arrays:"
|
||||||
|
{ $subsection pair } ;
|
||||||
|
|
||||||
|
ABOUT: "arrays"
|
||||||
|
|
||||||
|
HELP: array
|
||||||
|
{ $description "The class of fixed-length arrays. See " { $link "syntax-arrays" } " for syntax and " { $link "arrays" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: <array> ( n elt -- array )
|
||||||
|
{ $values { "n" "a non-negative integer" } { "elt" "an initial element" } { "array" "a new array" } }
|
||||||
|
{ $description "Creates a new array with the given length and all elements initially set to " { $snippet "elt" } "." } ;
|
||||||
|
|
||||||
|
{ <array> <quotation> <string> <sbuf> <vector> <byte-array> <bit-array> }
|
||||||
|
related-words
|
||||||
|
|
||||||
|
HELP: >array
|
||||||
|
{ $values { "seq" "a sequence" } { "array" array } }
|
||||||
|
{ $description "Outputs a freshly-allocated array with the same elements as a given sequence." } ;
|
||||||
|
|
||||||
|
{ >array >quotation >string >sbuf >vector >byte-array >bit-array }
|
||||||
|
related-words
|
||||||
|
|
||||||
|
HELP: 1array
|
||||||
|
{ $values { "x" object } { "array" array } }
|
||||||
|
{ $description "Create a new array with one element." } ;
|
||||||
|
|
||||||
|
{ 1array 2array 3array 4array } related-words
|
||||||
|
|
||||||
|
HELP: 2array
|
||||||
|
{ $values { "x" object } { "y" object } { "array" array } }
|
||||||
|
{ $description "Create a new array with two elements, with " { $snippet "x" } " appearing first." } ;
|
||||||
|
|
||||||
|
HELP: 3array
|
||||||
|
{ $values { "x" object } { "y" object } { "z" object } { "array" array } }
|
||||||
|
{ $description "Create a new array with three elements, with " { $snippet "x" } " appearing first." } ;
|
||||||
|
|
||||||
|
HELP: 4array
|
||||||
|
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" array } }
|
||||||
|
{ $description "Create a new array with four elements, with " { $snippet "w" } " appearing first." } ;
|
||||||
|
|
||||||
|
HELP: resize-array ( n array -- newarray )
|
||||||
|
{ $values { "n" "a non-negative integer" } { "array" array } { "newarray" "a new array" } }
|
||||||
|
{ $description "Creates a new array of " { $snippet "n" } " elements. The contents of the existing array are copied into the new array; if the new array is shorter, only an initial segment is copied, and if the new array is longer the remaining space is filled in with "{ $link f } "." } ;
|
||||||
|
|
||||||
|
HELP: pair
|
||||||
|
{ $class-description "The class of two-element arrays, known as pairs." } ;
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
USING: arrays kernel sequences sequences.private growable
|
||||||
|
tools.test vectors layouts system math math.functions
|
||||||
|
vectors.private ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
|
[ -2 { "a" "b" "c" } nth ] unit-test-fails
|
||||||
|
[ 10 { "a" "b" "c" } nth ] unit-test-fails
|
||||||
|
[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails
|
||||||
|
[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails
|
||||||
|
[ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test
|
||||||
|
[ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test
|
||||||
|
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
|
||||||
|
[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
|
||||||
|
[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
|
||||||
|
[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying eq? ] unit-test
|
||||||
|
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test
|
||||||
|
[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
|
||||||
|
[ { "a" "b" "c" "d" "e" } ]
|
||||||
|
[ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test
|
||||||
|
|
||||||
|
[ -1 f <array> ] unit-test-fails
|
||||||
|
[ cell-bits cell log2 - 2^ f <array> ] unit-test-fails
|
||||||
|
|
@ -0,0 +1,34 @@
|
||||||
|
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel kernel.private math math.private sequences
|
||||||
|
sequences.private ;
|
||||||
|
IN: arrays
|
||||||
|
|
||||||
|
M: array clone (clone) ;
|
||||||
|
M: array length array-capacity ;
|
||||||
|
M: array nth-unsafe >r >fixnum r> array-nth ;
|
||||||
|
M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
|
||||||
|
M: array resize resize-array ;
|
||||||
|
|
||||||
|
: >array ( seq -- array ) { } clone-like ;
|
||||||
|
|
||||||
|
M: object new drop f <array> ;
|
||||||
|
|
||||||
|
M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
|
||||||
|
|
||||||
|
M: array like drop dup array? [ >array ] unless ;
|
||||||
|
|
||||||
|
M: array equal?
|
||||||
|
over array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
INSTANCE: array sequence
|
||||||
|
|
||||||
|
: 1array ( x -- array ) 1 swap <array> ; flushable
|
||||||
|
|
||||||
|
: 2array ( x y -- array ) { } 2sequence ; flushable
|
||||||
|
|
||||||
|
: 3array ( x y z -- array ) { } 3sequence ; flushable
|
||||||
|
|
||||||
|
: 4array ( w x y z -- array ) { } 4sequence ; flushable
|
||||||
|
|
||||||
|
PREDICATE: array pair length 2 number= ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Fixed-size arrays
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
collections
|
||||||
|
|
@ -0,0 +1,296 @@
|
||||||
|
! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: help.markup help.syntax kernel sequences
|
||||||
|
sequences.private namespaces classes math ;
|
||||||
|
IN: assocs
|
||||||
|
|
||||||
|
ARTICLE: "alists" "Association lists"
|
||||||
|
"An " { $emphasis "association list" } ", abbreviated " { $emphasis "alist" } ", is an association represented as a sequence where all elements are key/value pairs. The " { $link sequence } " mixin is an instance of the " { $link assoc } " mixin, hence all sequences support the " { $link "assocs-protocol" } " in this way."
|
||||||
|
$nl
|
||||||
|
"While not an association list, note that " { $link f } " also implements the associative mapping protocol in a trivial way; it is an immutable assoc with no entries."
|
||||||
|
$nl
|
||||||
|
"An alist is slower to search than a hashtable for a large set of associations. The main advantage of an association list is that the elements are ordered; also sometimes it is more convenient to construct an association list with sequence words than to construct a hashtable with association words. Much of the time, hashtables are more appropriate. See " { $link "hashtables" } "."
|
||||||
|
$nl
|
||||||
|
"There is no special syntax for literal alists since they are just sequences; in practice, literals look like so:"
|
||||||
|
{ $code "{" " { key1 value1 }" " { key2 value2 }" "}" }
|
||||||
|
"To make an assoc into an alist:"
|
||||||
|
{ $subsection >alist } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs-protocol" "Associative mapping protocol"
|
||||||
|
"All associative mappings must be instances of a mixin class:"
|
||||||
|
{ $subsection assoc }
|
||||||
|
{ $subsection assoc? }
|
||||||
|
"All associative mappings must implement methods on the following generic words:"
|
||||||
|
{ $subsection at* }
|
||||||
|
{ $subsection assoc-size }
|
||||||
|
"At least one of the following two generic words must have a method; the " { $link assoc } " mixin has default definitions which are mutually recursive:"
|
||||||
|
{ $subsection >alist }
|
||||||
|
{ $subsection assoc-find }
|
||||||
|
"Mutable assocs should implement the following additional words:"
|
||||||
|
{ $subsection set-at }
|
||||||
|
{ $subsection delete-at }
|
||||||
|
{ $subsection clear-assoc }
|
||||||
|
"The following two words are optional:"
|
||||||
|
{ $subsection new-assoc }
|
||||||
|
{ $subsection assoc-like }
|
||||||
|
"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:"
|
||||||
|
{ $subsection assoc= }
|
||||||
|
{ $subsection assoc-hashcode }
|
||||||
|
"Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:"
|
||||||
|
{ $subsection assoc-clone-like } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
|
||||||
|
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
||||||
|
{ $subsection key? }
|
||||||
|
{ $subsection at }
|
||||||
|
{ $subsection value-at }
|
||||||
|
{ $subsection assoc-empty? }
|
||||||
|
{ $subsection keys }
|
||||||
|
{ $subsection values }
|
||||||
|
{ $subsection assoc-stack }
|
||||||
|
{ $see-also at* assoc-size } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
|
||||||
|
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
|
||||||
|
{ $subsection subassoc? }
|
||||||
|
{ $subsection intersect }
|
||||||
|
{ $subsection update }
|
||||||
|
{ $subsection union }
|
||||||
|
{ $subsection diff }
|
||||||
|
{ $subsection remove-all }
|
||||||
|
{ $subsection substitute }
|
||||||
|
{ $see-also key? } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
|
||||||
|
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
||||||
|
{ $subsection delete-at* }
|
||||||
|
{ $subsection rename-at }
|
||||||
|
{ $subsection change-at }
|
||||||
|
{ $subsection at+ }
|
||||||
|
{ $see-also set-at delete-at clear-assoc } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs-combinators" "Associative mapping combinators"
|
||||||
|
"The following combinators can be used on any associative mapping."
|
||||||
|
$nl
|
||||||
|
"The " { $link assoc-find } " combinator is part of the " { $link "assocs-protocol" } " and must be implemented once for each class of assoc. All other combinators are implemented in terms of this combinator."
|
||||||
|
$nl
|
||||||
|
"The standard functional programming idioms:"
|
||||||
|
{ $subsection assoc-each }
|
||||||
|
{ $subsection assoc-map }
|
||||||
|
{ $subsection assoc-push-if }
|
||||||
|
{ $subsection assoc-subset }
|
||||||
|
{ $subsection assoc-all? }
|
||||||
|
"Three additional combinators:"
|
||||||
|
{ $subsection cache }
|
||||||
|
{ $subsection map>assoc }
|
||||||
|
{ $subsection assoc>map } ;
|
||||||
|
|
||||||
|
ARTICLE: "assocs" "Associative mapping operations"
|
||||||
|
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
|
||||||
|
$nl
|
||||||
|
"Words used for working with assocs are in the " { $vocab-link "assocs" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Associative mappings implement a protocol:"
|
||||||
|
{ $subsection "assocs-protocol" }
|
||||||
|
"A large set of utility words work on any object whose class implements the associative mapping protocol."
|
||||||
|
{ $subsection "assocs-lookup" }
|
||||||
|
{ $subsection "assocs-mutation" }
|
||||||
|
{ $subsection "assocs-combinators" }
|
||||||
|
{ $subsection "assocs-sets" } ;
|
||||||
|
|
||||||
|
ABOUT: "assocs"
|
||||||
|
|
||||||
|
HELP: assoc
|
||||||
|
{ $class-description "A mixin class whose instances are associative mappings. Custom implementations of the assoc protocol should be declared as instances of this mixin for all assoc functionality to work correctly:"
|
||||||
|
{ $code "INSTANCE: avl-tree assoc" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: at*
|
||||||
|
{ $values { "key" "an object to look up in the assoc" } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } { "?" "a boolean indicating if the key was present" } }
|
||||||
|
{ $contract "Looks up the value associated with a key. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
|
||||||
|
|
||||||
|
HELP: set-at
|
||||||
|
{ $values { "value" "a value" } { "key" "a key to add" } { "assoc" assoc } }
|
||||||
|
{ $contract "Stores the key/value pair into the assoc." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: new-assoc
|
||||||
|
{ $values { "capacity" "a non-negative integer" } { "exemplar" assoc } { "newassoc" assoc } }
|
||||||
|
{ $contract "Creates a new assoc of the same size as " { $snippet "exemplar" } " which can hold " { $snippet "capacity" } " entries before growing." } ;
|
||||||
|
|
||||||
|
HELP: assoc-find
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
|
||||||
|
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
|
||||||
|
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
|
||||||
|
|
||||||
|
HELP: clear-assoc
|
||||||
|
{ $values { "assoc" assoc } }
|
||||||
|
{ $contract "Removes all entries from the assoc." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: delete-at
|
||||||
|
{ $values { "key" "a key" } { "assoc" assoc } }
|
||||||
|
{ $contract "Removes an entry from the assoc." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: assoc-size
|
||||||
|
{ $values { "assoc" assoc } { "n" "a non-negative integer" } }
|
||||||
|
{ $contract "Outputs the number of entries stored in the assoc." } ;
|
||||||
|
|
||||||
|
HELP: assoc-like
|
||||||
|
{ $values { "assoc" assoc } { "exemplar" assoc } { "newassoc" "a new assoc" } }
|
||||||
|
{ $contract "Creates a new assoc having the same entries as "{ $snippet "assoc" } " and the same type as " { $snippet "exemplar" } "." } ;
|
||||||
|
|
||||||
|
HELP: assoc-empty?
|
||||||
|
{ $values { "assoc" assoc } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if the assoc contains no entries." } ;
|
||||||
|
|
||||||
|
HELP: key?
|
||||||
|
{ $values { "key" object } { "assoc" assoc } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if an assoc contains a key." } ;
|
||||||
|
|
||||||
|
{ at at* key? } related-words
|
||||||
|
|
||||||
|
HELP: at
|
||||||
|
{ $values { "key" "an object" } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
|
||||||
|
{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link at* } "." } ;
|
||||||
|
|
||||||
|
HELP: assoc-each
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- )" } } }
|
||||||
|
{ $description "Applies a quotation to each entry in the assoc." }
|
||||||
|
{ $examples
|
||||||
|
{ $example
|
||||||
|
"H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
|
||||||
|
"0 swap [ nip + ] assoc-each ."
|
||||||
|
"64"
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: assoc-map
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
|
||||||
|
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the same type as the input." }
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example
|
||||||
|
": discount ( prices n -- newprices )"
|
||||||
|
" [ - ] curry assoc-each ;"
|
||||||
|
"H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
|
||||||
|
"2 discount ."
|
||||||
|
"H{ { \"bananas\" 3 } { \"apples\" 39 } { \"pears\" 15 } }"
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: assoc-push-if
|
||||||
|
{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
|
||||||
|
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
|
||||||
|
|
||||||
|
HELP: assoc-subset
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
|
||||||
|
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
|
||||||
|
|
||||||
|
HELP: assoc-all?
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
|
||||||
|
{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
|
||||||
|
|
||||||
|
HELP: subassoc?
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
|
||||||
|
{ $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
|
||||||
|
|
||||||
|
HELP: assoc=
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if two assocs contain the same entries. Unlike " { $link = } ", the two assocs may be of different types." }
|
||||||
|
{ $notes "Assoc implementations should define a method for the " { $link equal? } " generic word which calls this word after checking that both inputs have the same type." } ;
|
||||||
|
|
||||||
|
HELP: assoc-hashcode
|
||||||
|
{ $values { "n" "a non-negative integer" } { "assoc" assoc } { "code" integer } }
|
||||||
|
{ $description "Computes a hashcode for an assoc, such that equal assocs will have the same hashcode." }
|
||||||
|
{ $notes "Custom assoc implementations should use this word to implement a method for the " { $link hashcode* } " generic word." } ;
|
||||||
|
|
||||||
|
HELP: assoc-stack
|
||||||
|
{ $values { "key" "a key" } { "seq" "a sequence of assocs" } { "value" "a value or " { $link f } } }
|
||||||
|
{ $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." }
|
||||||
|
{ $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ;
|
||||||
|
|
||||||
|
HELP: value-at
|
||||||
|
{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } }
|
||||||
|
{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." }
|
||||||
|
{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ;
|
||||||
|
|
||||||
|
HELP: delete-at*
|
||||||
|
{ $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } }
|
||||||
|
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: rename-at
|
||||||
|
{ $values { "newkey" object } { "key" object } { "assoc" assoc } }
|
||||||
|
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }
|
||||||
|
;
|
||||||
|
|
||||||
|
HELP: keys
|
||||||
|
{ $values { "assoc" assoc } { "keys" "an array of keys" } }
|
||||||
|
{ $description "Outputs an array of all keys in the assoc." } ;
|
||||||
|
|
||||||
|
HELP: values
|
||||||
|
{ $values { "assoc" assoc } { "values" "an array of values" } }
|
||||||
|
{ $description "Outputs an array of all values in the assoc." } ;
|
||||||
|
|
||||||
|
{ keys values } related-words
|
||||||
|
|
||||||
|
HELP: intersect
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
|
||||||
|
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
|
||||||
|
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
|
||||||
|
|
||||||
|
HELP: update
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } }
|
||||||
|
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
|
||||||
|
{ $side-effects "assoc1" } ;
|
||||||
|
|
||||||
|
HELP: union
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
|
||||||
|
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
|
||||||
|
|
||||||
|
HELP: diff
|
||||||
|
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
|
||||||
|
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
|
||||||
|
;
|
||||||
|
HELP: remove-all
|
||||||
|
{ $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }
|
||||||
|
{ $description "Constructs a sequence consisting of all elements in " { $snippet "seq" } " which do not appear as keys in " { $snippet "assoc" } "." }
|
||||||
|
{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: substitute
|
||||||
|
{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
|
||||||
|
{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
|
||||||
|
{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
|
||||||
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
|
HELP: cache
|
||||||
|
{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
|
||||||
|
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: map>assoc
|
||||||
|
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
|
||||||
|
{ $description "Applies the quotation to each element of the sequence, and collects the keys and values into a new assoc having the same type as " { $snippet "exemplar" } "." } ;
|
||||||
|
|
||||||
|
HELP: assoc>map
|
||||||
|
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
|
||||||
|
{ $description "Applies the quotation to each entry of the assoc and collects the results into a new sequence of the same type as the exemplar." } ;
|
||||||
|
|
||||||
|
HELP: change-at
|
||||||
|
{ $values { "key" object } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } }
|
||||||
|
{ $description "Applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
{ change-at change-nth change } related-words
|
||||||
|
|
||||||
|
HELP: at+
|
||||||
|
{ $values { "n" number } { "key" object } { "assoc" assoc } }
|
||||||
|
{ $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." }
|
||||||
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: >alist
|
||||||
|
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
|
||||||
|
{ $contract "Converts an associative structure into an association list." }
|
||||||
|
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ;
|
||||||
|
|
@ -0,0 +1,89 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: kernel math namespaces tools.test vectors sequences
|
||||||
|
sequences.private hashtables io prettyprint assocs
|
||||||
|
continuations ;
|
||||||
|
|
||||||
|
[ t ] [ H{ } dup subassoc? ] unit-test
|
||||||
|
[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
|
||||||
|
[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
|
||||||
|
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
|
||||||
|
[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
|
||||||
|
|
||||||
|
! Test some combinators
|
||||||
|
[
|
||||||
|
{ 4 14 32 }
|
||||||
|
] [
|
||||||
|
[
|
||||||
|
H{
|
||||||
|
{ 1 2 }
|
||||||
|
{ 3 4 }
|
||||||
|
{ 5 6 }
|
||||||
|
} [ * 2 + , ] assoc-each
|
||||||
|
] { } make
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [ H{ } [ 2drop f ] assoc-all? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 1 } } [ = ] assoc-all? ] unit-test
|
||||||
|
[ f ] [ H{ { 1 2 } } [ = ] assoc-all? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
|
||||||
|
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
|
||||||
|
|
||||||
|
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
|
||||||
|
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
|
||||||
|
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
|
||||||
|
[ drop 3 >= ] assoc-subset
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 21 ] [
|
||||||
|
0 H{
|
||||||
|
{ 1 2 }
|
||||||
|
{ 3 4 }
|
||||||
|
{ 5 6 }
|
||||||
|
} [
|
||||||
|
+ +
|
||||||
|
] assoc-each
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
H{ } clone "cache-test" set
|
||||||
|
|
||||||
|
[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
|
||||||
|
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
|
||||||
|
[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
|
||||||
|
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
H{ { "factor" "rocks" } { 3 4 } }
|
||||||
|
] [
|
||||||
|
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
|
||||||
|
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
|
||||||
|
intersect
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
H{ { 1 2 } { 2 3 } { 6 5 } }
|
||||||
|
] [
|
||||||
|
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
|
||||||
|
union
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ H{ { 1 2 } { 2 3 } } t ] [
|
||||||
|
f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
H{ { 1 f } }
|
||||||
|
] [
|
||||||
|
H{ { 1 f } } H{ { 1 f } } intersect
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
|
||||||
|
|
||||||
|
[ H{ { "hi" 2 } { 3 4 } } ]
|
||||||
|
[ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ H{ { 1 2 } { 3 4 } } ]
|
||||||
|
[ "hi" 5 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
|
||||||
|
unit-test
|
||||||
|
|
@ -0,0 +1,179 @@
|
||||||
|
! Copyright (C) 2007 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel sequences arrays math sequences.private vectors ;
|
||||||
|
IN: assocs
|
||||||
|
|
||||||
|
MIXIN: assoc
|
||||||
|
|
||||||
|
GENERIC: at* ( key assoc -- value/f ? )
|
||||||
|
GENERIC: set-at ( value key assoc -- )
|
||||||
|
GENERIC: new-assoc ( capacity exemplar -- newassoc )
|
||||||
|
GENERIC: delete-at ( key assoc -- )
|
||||||
|
GENERIC: clear-assoc ( assoc -- )
|
||||||
|
GENERIC: assoc-size ( assoc -- n )
|
||||||
|
GENERIC: assoc-like ( assoc exemplar -- newassoc )
|
||||||
|
|
||||||
|
M: assoc assoc-like drop ;
|
||||||
|
|
||||||
|
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
|
|
||||||
|
GENERIC: >alist ( assoc -- newassoc )
|
||||||
|
|
||||||
|
GENERIC# assoc-find 1 ( assoc quot -- key value ? ) inline
|
||||||
|
|
||||||
|
M: assoc assoc-find
|
||||||
|
>r >alist [ first2 ] r> compose find swap
|
||||||
|
[ first2 t ] [ drop f f f ] if ;
|
||||||
|
|
||||||
|
: key? ( key assoc -- ? ) at* nip ; inline
|
||||||
|
|
||||||
|
: assoc-each ( assoc quot -- )
|
||||||
|
[ f ] compose assoc-find 3drop ; inline
|
||||||
|
|
||||||
|
: (assoc>map) ( quot accum -- quot' )
|
||||||
|
[ push ] curry compose ; inline
|
||||||
|
|
||||||
|
: assoc>map ( assoc quot exemplar -- seq )
|
||||||
|
>r over assoc-size
|
||||||
|
<vector> [ (assoc>map) assoc-each ] keep
|
||||||
|
r> like ; inline
|
||||||
|
|
||||||
|
: assoc-map ( assoc quot -- newassoc )
|
||||||
|
over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
|
||||||
|
inline
|
||||||
|
|
||||||
|
: assoc-push-if ( key value quot accum -- )
|
||||||
|
>r pick pick 2slip r> roll
|
||||||
|
[ >r 2array r> push ] [ 3drop ] if ; inline
|
||||||
|
|
||||||
|
: assoc-pusher ( quot -- quot' accum )
|
||||||
|
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
|
||||||
|
|
||||||
|
: assoc-subset ( assoc quot -- subassoc )
|
||||||
|
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
|
||||||
|
|
||||||
|
: assoc-all? ( assoc quot -- ? )
|
||||||
|
[ not ] compose assoc-find 2nip not ; inline
|
||||||
|
|
||||||
|
: assoc-contains? ( assoc quot -- ? )
|
||||||
|
assoc-find 2nip ; inline
|
||||||
|
|
||||||
|
: at ( key assoc -- value/f )
|
||||||
|
at* drop ; inline
|
||||||
|
|
||||||
|
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
|
over assoc-size swap new-assoc
|
||||||
|
swap [ swap pick set-at ] assoc-each ;
|
||||||
|
|
||||||
|
: keys ( assoc -- keys )
|
||||||
|
[ drop ] { } assoc>map ;
|
||||||
|
|
||||||
|
: values ( assoc -- values )
|
||||||
|
[ nip ] { } assoc>map ;
|
||||||
|
|
||||||
|
: delete-at* ( key assoc -- old ? )
|
||||||
|
[ at* ] 2keep delete-at ;
|
||||||
|
|
||||||
|
: rename-at ( newkey key assoc -- )
|
||||||
|
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
|
||||||
|
|
||||||
|
: assoc-empty? ( assoc -- ? )
|
||||||
|
assoc-size zero? ;
|
||||||
|
|
||||||
|
: (assoc-stack) ( key i seq -- value )
|
||||||
|
over 0 < [
|
||||||
|
3drop f
|
||||||
|
] [
|
||||||
|
3dup nth-unsafe at*
|
||||||
|
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
: assoc-stack ( key seq -- value )
|
||||||
|
dup length 1- swap (assoc-stack) ;
|
||||||
|
|
||||||
|
: subassoc? ( assoc1 assoc2 -- ? )
|
||||||
|
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
|
||||||
|
|
||||||
|
: assoc= ( assoc1 assoc2 -- ? )
|
||||||
|
2dup subassoc? >r swap subassoc? r> and ;
|
||||||
|
|
||||||
|
: assoc-hashcode ( n assoc -- code )
|
||||||
|
swap [
|
||||||
|
tuck swap hashcode* >r swap hashcode* 2/ r> bitxor
|
||||||
|
] curry { } assoc>map hashcode ;
|
||||||
|
|
||||||
|
: intersect ( assoc1 assoc2 -- intersection )
|
||||||
|
swap [ nip key? ] curry assoc-subset ;
|
||||||
|
|
||||||
|
: update ( assoc1 assoc2 -- )
|
||||||
|
swap [ swapd set-at ] curry assoc-each ;
|
||||||
|
|
||||||
|
: union ( assoc1 assoc2 -- union )
|
||||||
|
2dup [ assoc-size ] 2apply + pick new-assoc
|
||||||
|
[ rot update ] keep [ swap update ] keep ;
|
||||||
|
|
||||||
|
: diff ( assoc1 assoc2 -- diff )
|
||||||
|
swap [ nip key? not ] curry assoc-subset ;
|
||||||
|
|
||||||
|
: remove-all ( assoc seq -- subseq )
|
||||||
|
swap [ key? not ] curry subset ;
|
||||||
|
|
||||||
|
: substitute ( assoc seq -- )
|
||||||
|
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
|
||||||
|
|
||||||
|
: cache ( key assoc quot -- value )
|
||||||
|
pick pick at [
|
||||||
|
>r 3drop r>
|
||||||
|
] [
|
||||||
|
pick rot >r >r call dup r> r> set-at
|
||||||
|
] if* ; inline
|
||||||
|
|
||||||
|
: change-at ( key assoc quot -- )
|
||||||
|
[ >r at r> call ] 3keep drop set-at ; inline
|
||||||
|
|
||||||
|
: at+ ( n key assoc -- )
|
||||||
|
[ 0 or + ] change-at ;
|
||||||
|
|
||||||
|
: map>assoc ( seq quot exemplar -- assoc )
|
||||||
|
>r [ 2array ] compose map r> assoc-like ; inline
|
||||||
|
|
||||||
|
M: assoc >alist [ 2array ] { } assoc>map ;
|
||||||
|
|
||||||
|
: value-at ( value assoc -- key/f )
|
||||||
|
swap [ = nip ] curry assoc-find 2drop ;
|
||||||
|
|
||||||
|
: search-alist ( key alist -- pair i )
|
||||||
|
[ first = ] curry* find swap ; inline
|
||||||
|
|
||||||
|
M: sequence at*
|
||||||
|
search-alist [ second t ] [ f ] if ;
|
||||||
|
|
||||||
|
M: sequence set-at
|
||||||
|
2dup search-alist
|
||||||
|
[ 2nip set-second ]
|
||||||
|
[ drop >r swap 2array r> push ] if ;
|
||||||
|
|
||||||
|
M: sequence new-assoc drop <vector> ;
|
||||||
|
|
||||||
|
M: sequence clear-assoc delete-all ;
|
||||||
|
|
||||||
|
M: sequence delete-at
|
||||||
|
tuck search-alist nip
|
||||||
|
[ swap delete-nth ] [ drop ] if* ;
|
||||||
|
|
||||||
|
M: sequence assoc-size length ;
|
||||||
|
|
||||||
|
M: sequence assoc-clone-like
|
||||||
|
>r >alist r> clone-like ;
|
||||||
|
|
||||||
|
M: sequence assoc-like
|
||||||
|
over sequence? [ like ] [ assoc-clone-like ] if ;
|
||||||
|
|
||||||
|
M: sequence >alist ;
|
||||||
|
|
||||||
|
! Override sequence => assoc instance for f
|
||||||
|
M: f clear-assoc drop ;
|
||||||
|
|
||||||
|
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
|
||||||
|
|
||||||
|
INSTANCE: sequence assoc
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Daniel Ehrenberg
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Associative structure protocol
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
collections
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,49 @@
|
||||||
|
USING: arrays help.markup help.syntax kernel
|
||||||
|
kernel.private 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. The literal syntax is covered in " { $link "syntax-bit-arrays" } "."
|
||||||
|
$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-byte-arrays" } "."
|
||||||
|
$nl
|
||||||
|
"Bit arrays form a class of objects:"
|
||||||
|
{ $subsection bit-array }
|
||||||
|
{ $subsection bit-array? }
|
||||||
|
"Creating new bit arrays:"
|
||||||
|
{ $subsection >bit-array }
|
||||||
|
{ $subsection <bit-array> }
|
||||||
|
"Efficiently setting and clearing all bits in a bit array:"
|
||||||
|
{ $subsection set-bits }
|
||||||
|
{ $subsection clear-bits } ;
|
||||||
|
|
||||||
|
ABOUT: "bit-arrays"
|
||||||
|
|
||||||
|
HELP: bit-array
|
||||||
|
{ $description "The class of fixed-length bit arrays. See " { $link "syntax-bit-arrays" } " for syntax and " { $link "bit-arrays" } " for general information." } ;
|
||||||
|
|
||||||
|
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 ] change-each" }
|
||||||
|
}
|
||||||
|
{ $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 ] change-each" }
|
||||||
|
}
|
||||||
|
{ $side-effects "bit-array" } ;
|
||||||
|
|
@ -0,0 +1,48 @@
|
||||||
|
USING: sequences arrays bit-arrays kernel tools.test math
|
||||||
|
random ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
|
[ 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 dup [ not ] change-each
|
||||||
|
[ >array ] 2apply
|
||||||
|
] 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 [ drop 2 random zero? ] map
|
||||||
|
dup >bit-array >array =
|
||||||
|
] all?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ?{ f } ] [
|
||||||
|
1 2 { t f t f } <slice> >bit-array
|
||||||
|
] unit-test
|
||||||
|
|
@ -0,0 +1,51 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: math alien kernel kernel.private sequences
|
||||||
|
sequences.private ;
|
||||||
|
IN: bit-arrays
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: n>cell -5 shift 4 * ; inline
|
||||||
|
|
||||||
|
: cell/bit ( n alien -- byte bit )
|
||||||
|
over n>cell alien-unsigned-4 swap 31 bitand ; inline
|
||||||
|
|
||||||
|
: set-bit ( ? byte bit -- byte )
|
||||||
|
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
|
||||||
|
|
||||||
|
: bits>bytes 7 + -3 shift ; inline
|
||||||
|
|
||||||
|
: bits>cells 31 + -5 shift ; inline
|
||||||
|
|
||||||
|
: (set-bits) ( bit-array n -- )
|
||||||
|
over length bits>cells -rot [
|
||||||
|
swap rot 4 * set-alien-unsigned-4
|
||||||
|
] 2curry each ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
M: bit-array length array-capacity ;
|
||||||
|
|
||||||
|
M: bit-array nth-unsafe cell/bit bit? ;
|
||||||
|
|
||||||
|
M: bit-array set-nth-unsafe
|
||||||
|
[ cell/bit set-bit ] 2keep
|
||||||
|
swap n>cell set-alien-unsigned-4 ;
|
||||||
|
|
||||||
|
: clear-bits ( bit-array -- ) 0 (set-bits) ;
|
||||||
|
|
||||||
|
: set-bits ( bit-array -- ) -1 (set-bits) ;
|
||||||
|
|
||||||
|
M: bit-array clone (clone) ;
|
||||||
|
|
||||||
|
: >bit-array ( seq -- bit-array ) ?{ } clone-like ; inline
|
||||||
|
|
||||||
|
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
||||||
|
|
||||||
|
M: bit-array new drop <bit-array> ;
|
||||||
|
|
||||||
|
M: bit-array equal?
|
||||||
|
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
INSTANCE: bit-array sequence
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Fixed-size bit arrays
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
collections
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,50 @@
|
||||||
|
USING: compiler vocabs.loader system sequences namespaces
|
||||||
|
parser kernel kernel.private classes classes.private
|
||||||
|
arrays hashtables vectors tuples sbufs inference.dataflow
|
||||||
|
hashtables.private sequences.private math tuples.private
|
||||||
|
growable namespaces.private alien.remote-control assocs
|
||||||
|
words generator command-line vocabs io prettyprint ;
|
||||||
|
|
||||||
|
"bootstrap.math" vocab [
|
||||||
|
"cpu." cpu append require
|
||||||
|
|
||||||
|
global [ { "compiler" } add-use ] bind
|
||||||
|
|
||||||
|
"-no-stack-traces" cli-args member? [
|
||||||
|
f compiled-stack-traces set-global
|
||||||
|
] when
|
||||||
|
|
||||||
|
! Compile a set of words ahead of our general
|
||||||
|
! compile-all. This set of words was determined
|
||||||
|
! semi-empirically using the profiler. It improves
|
||||||
|
! bootstrap time significantly, because frequenly
|
||||||
|
! called words which are also quick to compile
|
||||||
|
! are replaced by compiled definitions as soon as
|
||||||
|
! possible.
|
||||||
|
{
|
||||||
|
roll -roll declare not
|
||||||
|
|
||||||
|
tuple-class-eq? array? hashtable? vector?
|
||||||
|
tuple? sbuf? node? tombstone?
|
||||||
|
|
||||||
|
array-capacity array-nth set-array-nth
|
||||||
|
|
||||||
|
wrap probe
|
||||||
|
|
||||||
|
delegate
|
||||||
|
|
||||||
|
underlying
|
||||||
|
|
||||||
|
find-pair-next namestack*
|
||||||
|
|
||||||
|
bitand bitor bitxor bitnot
|
||||||
|
|
||||||
|
+ 1+ 1- 2/ < <= > >= shift min
|
||||||
|
|
||||||
|
new nth push pop peek hashcode* = get set
|
||||||
|
|
||||||
|
. lines
|
||||||
|
} [ compile ] each
|
||||||
|
|
||||||
|
[ recompile ] parse-hook set-global
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading the compiler in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,24 @@
|
||||||
|
USING: help help.topics help.syntax help.crossref
|
||||||
|
help.definitions io io.files kernel namespaces vocabs sequences
|
||||||
|
parser vocabs.loader ;
|
||||||
|
IN: bootstrap.help
|
||||||
|
|
||||||
|
: load-help
|
||||||
|
t load-help? set-global
|
||||||
|
|
||||||
|
vocabs
|
||||||
|
[ vocab-root ] subset
|
||||||
|
[ vocab-source-loaded? ] subset
|
||||||
|
[
|
||||||
|
dup vocab-docs-loaded? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
dup vocab-root swap load-docs
|
||||||
|
] if
|
||||||
|
] each
|
||||||
|
|
||||||
|
"help.handbook" require
|
||||||
|
|
||||||
|
global [ "help" use+ ] bind ;
|
||||||
|
|
||||||
|
load-help
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading the help system in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
USING: help.markup help.syntax io io.files ;
|
||||||
|
IN: bootstrap.image
|
||||||
|
|
||||||
|
ARTICLE: "bootstrap.image" "Bootstrapping new images"
|
||||||
|
"A new image can be built from source; this is known as " { $emphasis "bootstrap" } ". Bootstrap is a two-step process. The first stage is the creation of a bootstrap image from a running Factor instance:"
|
||||||
|
{ $subsection make-image }
|
||||||
|
"The second bootstrapping stage is initiated by running the resulting bootstrap image:"
|
||||||
|
{ $code "./factor -i=boot.x86.32.image" }
|
||||||
|
"This stage loads additional code, compiles all words, and dumps a final " { $snippet "factor.image" } "."
|
||||||
|
$nl
|
||||||
|
"The bootstrap process can be customized with command-line switches."
|
||||||
|
{ $see-also "runtime-cli-args" "bootstrap-cli-args" } ;
|
||||||
|
|
||||||
|
ABOUT: "bootstrap.image"
|
||||||
|
|
||||||
|
HELP: make-image
|
||||||
|
{ $values { "architecture" "a string" } }
|
||||||
|
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
|
||||||
|
{ $code "x86.32" "x86.64" "ppc" "arm" }
|
||||||
|
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;
|
||||||
|
|
@ -0,0 +1,461 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien arrays bit-arrays byte-arrays generic assocs
|
||||||
|
hashtables assocs hashtables.private io kernel kernel.private
|
||||||
|
math namespaces parser prettyprint sequences sequences.private
|
||||||
|
strings sbufs vectors words quotations assocs system layouts
|
||||||
|
splitting growable math.functions classes tuples words.private
|
||||||
|
io.binary io.files vocabs vocabs.loader source-files
|
||||||
|
definitions debugger float-arrays quotations.private
|
||||||
|
combinators.private combinators ;
|
||||||
|
IN: bootstrap.image
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
! Constants
|
||||||
|
|
||||||
|
: image-magic HEX: 0f0e0d0c ; inline
|
||||||
|
: image-version 4 ; inline
|
||||||
|
|
||||||
|
: char bootstrap-cell 2/ ; inline
|
||||||
|
|
||||||
|
: data-base 1024 ; inline
|
||||||
|
|
||||||
|
: userenv-size 40 ; inline
|
||||||
|
|
||||||
|
: header-size 10 ; inline
|
||||||
|
|
||||||
|
: data-heap-size-offset 3 ; inline
|
||||||
|
: t-offset 6 ; inline
|
||||||
|
: 0-offset 7 ; inline
|
||||||
|
: 1-offset 8 ; inline
|
||||||
|
: -1-offset 9 ; inline
|
||||||
|
|
||||||
|
: array-start 2 bootstrap-cells object tag-number - ;
|
||||||
|
: scan@ array-start 4 - ;
|
||||||
|
: wrapper@ bootstrap-cell object tag-number - ;
|
||||||
|
: word-xt@ 8 bootstrap-cells object tag-number - ;
|
||||||
|
: quot-array@ bootstrap-cell object tag-number - ;
|
||||||
|
: quot-xt@ 2 bootstrap-cells object tag-number - ;
|
||||||
|
|
||||||
|
! The image being constructed; a vector of word-size integers
|
||||||
|
SYMBOL: image
|
||||||
|
|
||||||
|
! Object cache
|
||||||
|
SYMBOL: objects
|
||||||
|
|
||||||
|
! Image output format
|
||||||
|
SYMBOL: big-endian
|
||||||
|
|
||||||
|
! Bootstrap architecture name
|
||||||
|
SYMBOL: architecture
|
||||||
|
|
||||||
|
! Bootstrap global namesapce
|
||||||
|
SYMBOL: bootstrap-global
|
||||||
|
|
||||||
|
! Boot quotation, set in stage1.factor
|
||||||
|
SYMBOL: bootstrap-boot-quot
|
||||||
|
|
||||||
|
! JIT parameters
|
||||||
|
SYMBOL: jit-code-format
|
||||||
|
SYMBOL: jit-setup
|
||||||
|
SYMBOL: jit-prolog
|
||||||
|
SYMBOL: jit-word-primitive-jump
|
||||||
|
SYMBOL: jit-word-primitive-call
|
||||||
|
SYMBOL: jit-word-jump
|
||||||
|
SYMBOL: jit-word-call
|
||||||
|
SYMBOL: jit-push-wrapper
|
||||||
|
SYMBOL: jit-push-literal
|
||||||
|
SYMBOL: jit-if-word
|
||||||
|
SYMBOL: jit-if-jump
|
||||||
|
SYMBOL: jit-if-call
|
||||||
|
SYMBOL: jit-dispatch-word
|
||||||
|
SYMBOL: jit-dispatch
|
||||||
|
SYMBOL: jit-epilog
|
||||||
|
SYMBOL: jit-return
|
||||||
|
|
||||||
|
: userenv-offset ( symbol -- n )
|
||||||
|
{
|
||||||
|
{ bootstrap-boot-quot 20 }
|
||||||
|
{ bootstrap-global 21 }
|
||||||
|
{ jit-code-format 22 }
|
||||||
|
{ jit-setup 23 }
|
||||||
|
{ jit-prolog 24 }
|
||||||
|
{ jit-word-primitive-jump 25 }
|
||||||
|
{ jit-word-primitive-call 26 }
|
||||||
|
{ jit-word-jump 27 }
|
||||||
|
{ jit-word-call 28 }
|
||||||
|
{ jit-push-wrapper 29 }
|
||||||
|
{ jit-push-literal 30 }
|
||||||
|
{ jit-if-word 31 }
|
||||||
|
{ jit-if-jump 32 }
|
||||||
|
{ jit-if-call 33 }
|
||||||
|
{ jit-dispatch-word 34 }
|
||||||
|
{ jit-dispatch 35 }
|
||||||
|
{ jit-epilog 36 }
|
||||||
|
{ jit-return 37 }
|
||||||
|
} at header-size + ;
|
||||||
|
|
||||||
|
: emit ( cell -- ) image get push ;
|
||||||
|
|
||||||
|
: emit-64 ( cell -- )
|
||||||
|
bootstrap-cell 8 = [
|
||||||
|
emit
|
||||||
|
] [
|
||||||
|
d>w/w big-endian get [ swap ] unless emit emit
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: emit-seq ( seq -- ) image get push-all ;
|
||||||
|
|
||||||
|
: fixup ( value offset -- ) image get set-nth ;
|
||||||
|
|
||||||
|
: heap-size ( -- size )
|
||||||
|
image get length header-size - userenv-size -
|
||||||
|
bootstrap-cells ;
|
||||||
|
|
||||||
|
: here ( -- size ) heap-size data-base + ;
|
||||||
|
|
||||||
|
: here-as ( tag -- pointer ) here swap bitor ;
|
||||||
|
|
||||||
|
: align-here ( -- )
|
||||||
|
here 8 mod 4 = [ 0 emit ] when ;
|
||||||
|
|
||||||
|
: emit-fixnum ( n -- ) tag-bits get shift emit ;
|
||||||
|
|
||||||
|
: emit-object ( header tag quot -- addr )
|
||||||
|
swap here-as >r swap tag-header emit call align-here r> ;
|
||||||
|
inline
|
||||||
|
|
||||||
|
! Write an object to the image.
|
||||||
|
GENERIC: ' ( obj -- ptr )
|
||||||
|
|
||||||
|
! Image header
|
||||||
|
|
||||||
|
: emit-header ( -- )
|
||||||
|
image-magic emit
|
||||||
|
image-version emit
|
||||||
|
data-base emit ! relocation base at end of header
|
||||||
|
0 emit ! size of data heap set later
|
||||||
|
0 emit ! reloc base of code heap is 0
|
||||||
|
0 emit ! size of code heap is 0
|
||||||
|
0 emit ! pointer to t object
|
||||||
|
0 emit ! pointer to bignum 0
|
||||||
|
0 emit ! pointer to bignum 1
|
||||||
|
0 emit ! pointer to bignum -1
|
||||||
|
userenv-size [ f ' emit ] times ;
|
||||||
|
|
||||||
|
: emit-userenv ( symbol -- )
|
||||||
|
dup get ' swap userenv-offset fixup ;
|
||||||
|
|
||||||
|
! Bignums
|
||||||
|
|
||||||
|
: bignum-bits bootstrap-cell-bits 2 - ;
|
||||||
|
|
||||||
|
: bignum-radix bignum-bits 2^ 1- ;
|
||||||
|
|
||||||
|
: (bignum>seq) ( n -- )
|
||||||
|
dup zero? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
dup bignum-radix bitand ,
|
||||||
|
bignum-bits neg shift (bignum>seq)
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: bignum>seq ( n -- seq )
|
||||||
|
#! n is positive or zero.
|
||||||
|
[ (bignum>seq) ] { } make ;
|
||||||
|
|
||||||
|
: emit-bignum ( n -- )
|
||||||
|
[ 0 < 1 0 ? ] keep abs bignum>seq
|
||||||
|
dup length 1+ emit-fixnum
|
||||||
|
swap emit emit-seq ;
|
||||||
|
|
||||||
|
M: bignum '
|
||||||
|
bignum tag-number dup [ emit-bignum ] emit-object ;
|
||||||
|
|
||||||
|
! Fixnums
|
||||||
|
|
||||||
|
M: fixnum '
|
||||||
|
#! When generating a 32-bit image on a 64-bit system,
|
||||||
|
#! some fixnums should be bignums.
|
||||||
|
dup most-negative-fixnum most-positive-fixnum between?
|
||||||
|
[ tag-bits get shift ] [ >bignum ' ] if ;
|
||||||
|
|
||||||
|
! Floats
|
||||||
|
|
||||||
|
M: float '
|
||||||
|
float tag-number dup [
|
||||||
|
align-here double>bits emit-64
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
! Special objects
|
||||||
|
|
||||||
|
! Padded with fixnums for 8-byte alignment
|
||||||
|
|
||||||
|
: t, t t-offset fixup ;
|
||||||
|
|
||||||
|
M: f '
|
||||||
|
#! f is #define F RETAG(0,F_TYPE)
|
||||||
|
drop \ f tag-number ;
|
||||||
|
|
||||||
|
: 0, 0 >bignum ' 0-offset fixup ;
|
||||||
|
: 1, 1 >bignum ' 1-offset fixup ;
|
||||||
|
: -1, -1 >bignum ' -1-offset fixup ;
|
||||||
|
|
||||||
|
! Beginning of the image
|
||||||
|
|
||||||
|
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
|
||||||
|
|
||||||
|
! Words
|
||||||
|
|
||||||
|
: emit-word ( word -- )
|
||||||
|
[
|
||||||
|
dup hashcode ' ,
|
||||||
|
dup word-name ' ,
|
||||||
|
dup word-vocabulary ' ,
|
||||||
|
dup word-def ' ,
|
||||||
|
dup word-props ' ,
|
||||||
|
f ' ,
|
||||||
|
0 ,
|
||||||
|
0 ,
|
||||||
|
] { } make
|
||||||
|
\ word type-number object tag-number
|
||||||
|
[ emit-seq ] emit-object
|
||||||
|
swap objects get set-at ;
|
||||||
|
|
||||||
|
: word-error ( word msg -- * )
|
||||||
|
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||||
|
|
||||||
|
: transfer-word ( word -- word )
|
||||||
|
dup target-word [ ] [ word-name no-word ] ?if ;
|
||||||
|
|
||||||
|
: fixup-word ( word -- offset )
|
||||||
|
transfer-word dup objects get at
|
||||||
|
[ ] [ "Not in image: " word-error ] ?if ;
|
||||||
|
|
||||||
|
: fixup-words ( -- )
|
||||||
|
image get [ dup word? [ fixup-word ] when ] change-each ;
|
||||||
|
|
||||||
|
M: word ' ;
|
||||||
|
|
||||||
|
! Wrappers
|
||||||
|
|
||||||
|
M: wrapper '
|
||||||
|
wrapped ' wrapper type-number object tag-number
|
||||||
|
[ emit ] emit-object ;
|
||||||
|
|
||||||
|
! Strings
|
||||||
|
: 16be> 0 [ swap 16 shift bitor ] reduce ;
|
||||||
|
: 16le> <reversed> 16be> ;
|
||||||
|
|
||||||
|
: emit-chars ( seq -- )
|
||||||
|
char <groups>
|
||||||
|
big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if
|
||||||
|
emit-seq ;
|
||||||
|
|
||||||
|
: pack-string ( string -- newstr )
|
||||||
|
dup length 1+ char align 0 pad-right ;
|
||||||
|
|
||||||
|
: emit-string ( string -- ptr )
|
||||||
|
string type-number object tag-number [
|
||||||
|
dup length emit-fixnum
|
||||||
|
f ' emit
|
||||||
|
pack-string emit-chars
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
M: string '
|
||||||
|
#! We pool strings so that each string is only written once
|
||||||
|
#! to the image
|
||||||
|
objects get [ emit-string ] cache ;
|
||||||
|
|
||||||
|
: assert-empty ( seq -- )
|
||||||
|
length 0 assert= ;
|
||||||
|
|
||||||
|
: emit-dummy-array ( obj type -- ptr )
|
||||||
|
swap assert-empty
|
||||||
|
type-number object tag-number
|
||||||
|
[ 0 emit-fixnum ] emit-object ;
|
||||||
|
|
||||||
|
M: byte-array ' byte-array emit-dummy-array ;
|
||||||
|
|
||||||
|
M: bit-array ' bit-array emit-dummy-array ;
|
||||||
|
|
||||||
|
M: float-array ' float-array emit-dummy-array ;
|
||||||
|
|
||||||
|
! Arrays
|
||||||
|
: emit-array ( list type tag -- pointer )
|
||||||
|
>r >r [ ' ] map r> r> [
|
||||||
|
dup length emit-fixnum
|
||||||
|
emit-seq
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
: emit-tuple ( obj -- pointer )
|
||||||
|
objects get [
|
||||||
|
[ tuple>array unclip transfer-word , % ] { } make
|
||||||
|
tuple type-number dup emit-array
|
||||||
|
] cache ; inline
|
||||||
|
|
||||||
|
M: tuple ' emit-tuple ;
|
||||||
|
|
||||||
|
M: tombstone '
|
||||||
|
delegate
|
||||||
|
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||||
|
word-def first emit-tuple ;
|
||||||
|
|
||||||
|
M: array '
|
||||||
|
array type-number object tag-number emit-array ;
|
||||||
|
|
||||||
|
! Quotations
|
||||||
|
|
||||||
|
M: quotation '
|
||||||
|
objects get [
|
||||||
|
quotation-array '
|
||||||
|
quotation type-number object tag-number [
|
||||||
|
emit ! array
|
||||||
|
0 emit ! XT
|
||||||
|
] emit-object
|
||||||
|
] cache ;
|
||||||
|
|
||||||
|
! Vectors and sbufs
|
||||||
|
|
||||||
|
M: vector '
|
||||||
|
dup underlying ' swap length
|
||||||
|
vector type-number object tag-number [
|
||||||
|
emit-fixnum ! length
|
||||||
|
emit ! array ptr
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
M: sbuf '
|
||||||
|
dup underlying ' swap length
|
||||||
|
sbuf type-number object tag-number [
|
||||||
|
emit-fixnum ! length
|
||||||
|
emit ! array ptr
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
! Hashes
|
||||||
|
|
||||||
|
M: hashtable '
|
||||||
|
[ hash-array ' ] keep
|
||||||
|
hashtable type-number object tag-number [
|
||||||
|
dup hash-count emit-fixnum
|
||||||
|
hash-deleted emit-fixnum
|
||||||
|
emit ! array ptr
|
||||||
|
] emit-object ;
|
||||||
|
|
||||||
|
! Curries
|
||||||
|
|
||||||
|
M: curry '
|
||||||
|
dup curry-quot ' swap curry-obj '
|
||||||
|
\ curry type-number object tag-number
|
||||||
|
[ emit emit ] emit-object ;
|
||||||
|
|
||||||
|
! End of the image
|
||||||
|
|
||||||
|
: emit-words ( -- )
|
||||||
|
all-words [ emit-word ] each ;
|
||||||
|
|
||||||
|
: emit-global ( -- )
|
||||||
|
[
|
||||||
|
{
|
||||||
|
dictionary source-files
|
||||||
|
typemap builtins class<map update-map
|
||||||
|
} [ dup get swap bootstrap-word set ] each
|
||||||
|
] H{ } make-assoc
|
||||||
|
bootstrap-global set
|
||||||
|
bootstrap-global emit-userenv ;
|
||||||
|
|
||||||
|
: emit-boot-quot ( -- )
|
||||||
|
bootstrap-boot-quot emit-userenv ;
|
||||||
|
|
||||||
|
: emit-jit-data ( -- )
|
||||||
|
\ if jit-if-word set
|
||||||
|
\ dispatch jit-dispatch-word set
|
||||||
|
{
|
||||||
|
jit-code-format
|
||||||
|
jit-setup
|
||||||
|
jit-prolog
|
||||||
|
jit-word-primitive-jump
|
||||||
|
jit-word-primitive-call
|
||||||
|
jit-word-jump
|
||||||
|
jit-word-call
|
||||||
|
jit-push-wrapper
|
||||||
|
jit-push-literal
|
||||||
|
jit-if-word
|
||||||
|
jit-if-jump
|
||||||
|
jit-if-call
|
||||||
|
jit-dispatch-word
|
||||||
|
jit-dispatch
|
||||||
|
jit-epilog
|
||||||
|
jit-return
|
||||||
|
} [ emit-userenv ] each ;
|
||||||
|
|
||||||
|
: fixup-header ( -- )
|
||||||
|
heap-size data-heap-size-offset fixup ;
|
||||||
|
|
||||||
|
: end-image ( -- )
|
||||||
|
"Building generic words..." print flush
|
||||||
|
all-words [ generic? ] subset [ make-generic ] each
|
||||||
|
"Serializing words..." print flush
|
||||||
|
emit-words
|
||||||
|
"Serializing JIT data..." print flush
|
||||||
|
emit-jit-data
|
||||||
|
"Serializing global namespace..." print flush
|
||||||
|
emit-global
|
||||||
|
"Serializing boot quotation..." print flush
|
||||||
|
emit-boot-quot
|
||||||
|
"Performing word fixups..." print flush
|
||||||
|
fixup-words
|
||||||
|
"Performing header fixups..." print flush
|
||||||
|
fixup-header
|
||||||
|
"Image length: " write image get length .
|
||||||
|
"Object cache size: " write objects get assoc-size .
|
||||||
|
\ word global delete-at ;
|
||||||
|
|
||||||
|
! Image output
|
||||||
|
|
||||||
|
: (write-image) ( image -- )
|
||||||
|
bootstrap-cell big-endian get [
|
||||||
|
[ >be write ] curry each
|
||||||
|
] [
|
||||||
|
[ >le write ] curry each
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: image-name
|
||||||
|
"boot." architecture get ".image" 3append resource-path ;
|
||||||
|
|
||||||
|
: write-image ( image filename -- )
|
||||||
|
"Writing image to " write dup write "..." print flush
|
||||||
|
<file-writer> [ (write-image) ] with-stream ;
|
||||||
|
|
||||||
|
: prepare-profile ( arch -- )
|
||||||
|
"resource:core/bootstrap/layouts/layouts.factor" run-file
|
||||||
|
"resource:core/cpu/" swap {
|
||||||
|
{ "x86.32" "x86/32" }
|
||||||
|
{ "x86.64" "x86/64" }
|
||||||
|
{ "linux-ppc" "ppc/linux" }
|
||||||
|
{ "macosx-ppc" "ppc/macosx" }
|
||||||
|
{ "arm" "arm" }
|
||||||
|
} at "/bootstrap.factor" 3append ?resource-path run-file ;
|
||||||
|
|
||||||
|
: prepare-image ( arch -- )
|
||||||
|
dup architecture set prepare-profile
|
||||||
|
bootstrapping? on
|
||||||
|
load-help? off
|
||||||
|
800000 <vector> image set 20000 <hashtable> objects set ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: make-image ( architecture -- )
|
||||||
|
[
|
||||||
|
parse-hook off
|
||||||
|
prepare-image
|
||||||
|
begin-image
|
||||||
|
"resource:/core/bootstrap/stage1.factor" run-file
|
||||||
|
end-image
|
||||||
|
image get image-name write-image
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
: make-images ( -- )
|
||||||
|
{
|
||||||
|
"x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm"
|
||||||
|
} [ make-image ] each ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Bootstrap image generation
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
tools
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
USING: system vocabs vocabs.loader kernel ;
|
||||||
|
IN: bootstrap.io
|
||||||
|
|
||||||
|
"bootstrap.compiler" vocab [
|
||||||
|
unix? [ "io.unix" require ] when
|
||||||
|
winnt? [ "io.windows.nt" require ] when
|
||||||
|
wince? [ "io.windows.ce" require ] when
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading native I/O in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,40 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces math words kernel alien byte-arrays
|
||||||
|
hashtables vectors strings sbufs arrays bit-arrays
|
||||||
|
float-arrays quotations assocs layouts tuples ;
|
||||||
|
|
||||||
|
BIN: 111 tag-mask set
|
||||||
|
8 num-tags set
|
||||||
|
3 tag-bits set
|
||||||
|
|
||||||
|
23 num-types set
|
||||||
|
|
||||||
|
H{
|
||||||
|
{ fixnum BIN: 000 }
|
||||||
|
{ bignum BIN: 001 }
|
||||||
|
{ tuple BIN: 010 }
|
||||||
|
{ object BIN: 011 }
|
||||||
|
{ ratio BIN: 100 }
|
||||||
|
{ float BIN: 101 }
|
||||||
|
{ complex BIN: 110 }
|
||||||
|
{ POSTPONE: f BIN: 111 }
|
||||||
|
} tag-numbers set
|
||||||
|
|
||||||
|
tag-numbers get H{
|
||||||
|
{ array 8 }
|
||||||
|
{ wrapper 9 }
|
||||||
|
{ hashtable 10 }
|
||||||
|
{ vector 11 }
|
||||||
|
{ string 12 }
|
||||||
|
{ sbuf 13 }
|
||||||
|
{ quotation 14 }
|
||||||
|
{ dll 15 }
|
||||||
|
{ alien 16 }
|
||||||
|
{ word 17 }
|
||||||
|
{ byte-array 18 }
|
||||||
|
{ bit-array 19 }
|
||||||
|
{ float-array 20 }
|
||||||
|
{ curry 21 }
|
||||||
|
{ callstack 22 }
|
||||||
|
} union type-numbers set
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Description of low-level object layout for image generation
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
USE: vocabs.loader
|
||||||
|
|
||||||
|
"math.ratios" require
|
||||||
|
"math.floats" require
|
||||||
|
"math.complex" require
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading number tower in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1,597 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: bootstrap.primitives
|
||||||
|
USING: alien arrays byte-arrays generic hashtables
|
||||||
|
hashtables.private io kernel math namespaces parser sequences
|
||||||
|
strings vectors words quotations assocs layouts classes tuples
|
||||||
|
kernel.private vocabs vocabs.loader source-files definitions
|
||||||
|
slots classes.union words.private ;
|
||||||
|
|
||||||
|
! Some very tricky code creating a bootstrap embryo in the
|
||||||
|
! host image.
|
||||||
|
|
||||||
|
"Creating primitives and basic runtime structures..." print flush
|
||||||
|
|
||||||
|
load-help? off
|
||||||
|
crossref off
|
||||||
|
changed-words off
|
||||||
|
|
||||||
|
! Bring up a bare cross-compiling vocabulary.
|
||||||
|
"syntax" vocab vocab-words bootstrap-syntax set
|
||||||
|
|
||||||
|
"resource:core/bootstrap/syntax.factor" parse-file
|
||||||
|
H{ } clone dictionary set
|
||||||
|
call
|
||||||
|
|
||||||
|
! Create some empty vocabs where the below primitives and
|
||||||
|
! classes will go
|
||||||
|
{
|
||||||
|
"alien"
|
||||||
|
"arrays"
|
||||||
|
"bit-arrays"
|
||||||
|
"byte-arrays"
|
||||||
|
"classes.private"
|
||||||
|
"continuations.private"
|
||||||
|
"float-arrays"
|
||||||
|
"generator"
|
||||||
|
"growable"
|
||||||
|
"hashtables"
|
||||||
|
"hashtables.private"
|
||||||
|
"io"
|
||||||
|
"io.files"
|
||||||
|
"io.files.private"
|
||||||
|
"io.streams.c"
|
||||||
|
"kernel"
|
||||||
|
"kernel.private"
|
||||||
|
"math"
|
||||||
|
"math.private"
|
||||||
|
"memory"
|
||||||
|
"quotations"
|
||||||
|
"quotations.private"
|
||||||
|
"sbufs"
|
||||||
|
"sbufs.private"
|
||||||
|
"scratchpad"
|
||||||
|
"sequences"
|
||||||
|
"sequences.private"
|
||||||
|
"slots.private"
|
||||||
|
"strings"
|
||||||
|
"strings.private"
|
||||||
|
"system"
|
||||||
|
"threads.private"
|
||||||
|
"tools.profiler.private"
|
||||||
|
"tuples"
|
||||||
|
"tuples.private"
|
||||||
|
"words"
|
||||||
|
"words.private"
|
||||||
|
"vectors"
|
||||||
|
"vectors.private"
|
||||||
|
} [
|
||||||
|
dup find-vocab-root swap create-vocab
|
||||||
|
[ set-vocab-root ] keep
|
||||||
|
f swap set-vocab-source-loaded?
|
||||||
|
] each
|
||||||
|
|
||||||
|
H{ } clone source-files set
|
||||||
|
H{ } clone class<map set
|
||||||
|
H{ } clone update-map set
|
||||||
|
|
||||||
|
: make-primitive ( word vocab n -- ) >r create r> define ;
|
||||||
|
|
||||||
|
{
|
||||||
|
{ "(execute)" "words.private" }
|
||||||
|
{ "(call)" "kernel.private" }
|
||||||
|
{ "uncurry" "kernel.private" }
|
||||||
|
{ "string>sbuf" "sbufs.private" }
|
||||||
|
{ "bignum>fixnum" "math.private" }
|
||||||
|
{ "float>fixnum" "math.private" }
|
||||||
|
{ "fixnum>bignum" "math.private" }
|
||||||
|
{ "float>bignum" "math.private" }
|
||||||
|
{ "fixnum>float" "math.private" }
|
||||||
|
{ "bignum>float" "math.private" }
|
||||||
|
{ "<ratio>" "math.private" }
|
||||||
|
{ "string>float" "math.private" }
|
||||||
|
{ "float>string" "math.private" }
|
||||||
|
{ "float>bits" "math" }
|
||||||
|
{ "double>bits" "math" }
|
||||||
|
{ "bits>float" "math" }
|
||||||
|
{ "bits>double" "math" }
|
||||||
|
{ "<complex>" "math.private" }
|
||||||
|
{ "fixnum+" "math.private" }
|
||||||
|
{ "fixnum+fast" "math.private" }
|
||||||
|
{ "fixnum-" "math.private" }
|
||||||
|
{ "fixnum-fast" "math.private" }
|
||||||
|
{ "fixnum*" "math.private" }
|
||||||
|
{ "fixnum*fast" "math.private" }
|
||||||
|
{ "fixnum/i" "math.private" }
|
||||||
|
{ "fixnum-mod" "math.private" }
|
||||||
|
{ "fixnum/mod" "math.private" }
|
||||||
|
{ "fixnum-bitand" "math.private" }
|
||||||
|
{ "fixnum-bitor" "math.private" }
|
||||||
|
{ "fixnum-bitxor" "math.private" }
|
||||||
|
{ "fixnum-bitnot" "math.private" }
|
||||||
|
{ "fixnum-shift" "math.private" }
|
||||||
|
{ "fixnum<" "math.private" }
|
||||||
|
{ "fixnum<=" "math.private" }
|
||||||
|
{ "fixnum>" "math.private" }
|
||||||
|
{ "fixnum>=" "math.private" }
|
||||||
|
{ "bignum=" "math.private" }
|
||||||
|
{ "bignum+" "math.private" }
|
||||||
|
{ "bignum-" "math.private" }
|
||||||
|
{ "bignum*" "math.private" }
|
||||||
|
{ "bignum/i" "math.private" }
|
||||||
|
{ "bignum-mod" "math.private" }
|
||||||
|
{ "bignum/mod" "math.private" }
|
||||||
|
{ "bignum-bitand" "math.private" }
|
||||||
|
{ "bignum-bitor" "math.private" }
|
||||||
|
{ "bignum-bitxor" "math.private" }
|
||||||
|
{ "bignum-bitnot" "math.private" }
|
||||||
|
{ "bignum-shift" "math.private" }
|
||||||
|
{ "bignum<" "math.private" }
|
||||||
|
{ "bignum<=" "math.private" }
|
||||||
|
{ "bignum>" "math.private" }
|
||||||
|
{ "bignum>=" "math.private" }
|
||||||
|
{ "bignum-bit?" "math.private" }
|
||||||
|
{ "bignum-log2" "math.private" }
|
||||||
|
{ "byte-array>bignum" "math" }
|
||||||
|
{ "float=" "math.private" }
|
||||||
|
{ "float+" "math.private" }
|
||||||
|
{ "float-" "math.private" }
|
||||||
|
{ "float*" "math.private" }
|
||||||
|
{ "float/f" "math.private" }
|
||||||
|
{ "float-mod" "math.private" }
|
||||||
|
{ "float<" "math.private" }
|
||||||
|
{ "float<=" "math.private" }
|
||||||
|
{ "float>" "math.private" }
|
||||||
|
{ "float>=" "math.private" }
|
||||||
|
{ "<word>" "words" }
|
||||||
|
{ "update-xt" "words" }
|
||||||
|
{ "word-xt" "words" }
|
||||||
|
{ "drop" "kernel" }
|
||||||
|
{ "2drop" "kernel" }
|
||||||
|
{ "3drop" "kernel" }
|
||||||
|
{ "dup" "kernel" }
|
||||||
|
{ "2dup" "kernel" }
|
||||||
|
{ "3dup" "kernel" }
|
||||||
|
{ "rot" "kernel" }
|
||||||
|
{ "-rot" "kernel" }
|
||||||
|
{ "dupd" "kernel" }
|
||||||
|
{ "swapd" "kernel" }
|
||||||
|
{ "nip" "kernel" }
|
||||||
|
{ "2nip" "kernel" }
|
||||||
|
{ "tuck" "kernel" }
|
||||||
|
{ "over" "kernel" }
|
||||||
|
{ "pick" "kernel" }
|
||||||
|
{ "swap" "kernel" }
|
||||||
|
{ ">r" "kernel" }
|
||||||
|
{ "r>" "kernel" }
|
||||||
|
{ "eq?" "kernel" }
|
||||||
|
{ "getenv" "kernel.private" }
|
||||||
|
{ "setenv" "kernel.private" }
|
||||||
|
{ "(stat)" "io.files.private" }
|
||||||
|
{ "(directory)" "io.files.private" }
|
||||||
|
{ "data-gc" "memory" }
|
||||||
|
{ "code-gc" "memory" }
|
||||||
|
{ "gc-time" "memory" }
|
||||||
|
{ "save-image" "memory" }
|
||||||
|
{ "save-image-and-exit" "memory" }
|
||||||
|
{ "datastack" "kernel" }
|
||||||
|
{ "retainstack" "kernel" }
|
||||||
|
{ "callstack" "kernel" }
|
||||||
|
{ "set-datastack" "kernel" }
|
||||||
|
{ "set-retainstack" "kernel" }
|
||||||
|
{ "set-callstack" "kernel" }
|
||||||
|
{ "exit" "system" }
|
||||||
|
{ "data-room" "memory" }
|
||||||
|
{ "code-room" "memory" }
|
||||||
|
{ "os-env" "system" }
|
||||||
|
{ "millis" "system" }
|
||||||
|
{ "type" "kernel.private" }
|
||||||
|
{ "tag" "kernel.private" }
|
||||||
|
{ "cwd" "io.files" }
|
||||||
|
{ "cd" "io.files" }
|
||||||
|
{ "add-compiled-block" "generator" }
|
||||||
|
{ "dlopen" "alien" }
|
||||||
|
{ "dlsym" "alien" }
|
||||||
|
{ "dlclose" "alien" }
|
||||||
|
{ "<byte-array>" "byte-arrays" }
|
||||||
|
{ "<bit-array>" "bit-arrays" }
|
||||||
|
{ "<displaced-alien>" "alien" }
|
||||||
|
{ "alien-signed-cell" "alien" }
|
||||||
|
{ "set-alien-signed-cell" "alien" }
|
||||||
|
{ "alien-unsigned-cell" "alien" }
|
||||||
|
{ "set-alien-unsigned-cell" "alien" }
|
||||||
|
{ "alien-signed-8" "alien" }
|
||||||
|
{ "set-alien-signed-8" "alien" }
|
||||||
|
{ "alien-unsigned-8" "alien" }
|
||||||
|
{ "set-alien-unsigned-8" "alien" }
|
||||||
|
{ "alien-signed-4" "alien" }
|
||||||
|
{ "set-alien-signed-4" "alien" }
|
||||||
|
{ "alien-unsigned-4" "alien" }
|
||||||
|
{ "set-alien-unsigned-4" "alien" }
|
||||||
|
{ "alien-signed-2" "alien" }
|
||||||
|
{ "set-alien-signed-2" "alien" }
|
||||||
|
{ "alien-unsigned-2" "alien" }
|
||||||
|
{ "set-alien-unsigned-2" "alien" }
|
||||||
|
{ "alien-signed-1" "alien" }
|
||||||
|
{ "set-alien-signed-1" "alien" }
|
||||||
|
{ "alien-unsigned-1" "alien" }
|
||||||
|
{ "set-alien-unsigned-1" "alien" }
|
||||||
|
{ "alien-float" "alien" }
|
||||||
|
{ "set-alien-float" "alien" }
|
||||||
|
{ "alien-double" "alien" }
|
||||||
|
{ "set-alien-double" "alien" }
|
||||||
|
{ "alien-cell" "alien" }
|
||||||
|
{ "set-alien-cell" "alien" }
|
||||||
|
{ "alien>char-string" "alien" }
|
||||||
|
{ "string>char-alien" "alien" }
|
||||||
|
{ "alien>u16-string" "alien" }
|
||||||
|
{ "string>u16-alien" "alien" }
|
||||||
|
{ "(throw)" "kernel.private" }
|
||||||
|
{ "string>memory" "alien" }
|
||||||
|
{ "memory>string" "alien" }
|
||||||
|
{ "alien-address" "alien" }
|
||||||
|
{ "slot" "slots.private" }
|
||||||
|
{ "set-slot" "slots.private" }
|
||||||
|
{ "char-slot" "strings.private" }
|
||||||
|
{ "set-char-slot" "strings.private" }
|
||||||
|
{ "resize-array" "arrays" }
|
||||||
|
{ "resize-string" "strings" }
|
||||||
|
{ "(hashtable)" "hashtables.private" }
|
||||||
|
{ "<array>" "arrays" }
|
||||||
|
{ "begin-scan" "memory" }
|
||||||
|
{ "next-object" "memory" }
|
||||||
|
{ "end-scan" "memory" }
|
||||||
|
{ "size" "memory" }
|
||||||
|
{ "die" "kernel" }
|
||||||
|
{ "finalize-compile" "generator" }
|
||||||
|
{ "fopen" "io.streams.c" }
|
||||||
|
{ "fgetc" "io.streams.c" }
|
||||||
|
{ "fread" "io.streams.c" }
|
||||||
|
{ "fwrite" "io.streams.c" }
|
||||||
|
{ "fflush" "io.streams.c" }
|
||||||
|
{ "fclose" "io.streams.c" }
|
||||||
|
{ "<wrapper>" "kernel" }
|
||||||
|
{ "(clone)" "kernel" }
|
||||||
|
{ "array>vector" "vectors.private" }
|
||||||
|
{ "<string>" "strings" }
|
||||||
|
{ "(>tuple)" "tuples.private" }
|
||||||
|
{ "array>quotation" "quotations.private" }
|
||||||
|
{ "quotation-xt" "quotations" }
|
||||||
|
{ "<tuple>" "tuples.private" }
|
||||||
|
{ "tuple>array" "tuples" }
|
||||||
|
{ "profiling" "tools.profiler.private" }
|
||||||
|
{ "become" "tuples.private" }
|
||||||
|
{ "(sleep)" "threads.private" }
|
||||||
|
{ "<float-array>" "float-arrays" }
|
||||||
|
{ "curry" "kernel" }
|
||||||
|
{ "<tuple-boa>" "tuples.private" }
|
||||||
|
{ "class-hash" "kernel.private" }
|
||||||
|
{ "callstack>array" "kernel" }
|
||||||
|
{ "array>callstack" "kernel" }
|
||||||
|
}
|
||||||
|
dup length [ >r first2 r> make-primitive ] 2each
|
||||||
|
|
||||||
|
! Okay, now we have primitives fleshed out. Bring up the generic
|
||||||
|
! word system.
|
||||||
|
: builtin-predicate ( class predicate -- )
|
||||||
|
[
|
||||||
|
over "type" word-prop dup
|
||||||
|
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||||
|
] [ ] make define-predicate ;
|
||||||
|
|
||||||
|
: register-builtin ( class -- )
|
||||||
|
dup "type" word-prop builtins get set-nth ;
|
||||||
|
|
||||||
|
: intern-slots ( spec -- spec )
|
||||||
|
[
|
||||||
|
[ dup array? [ first2 create ] when ] map
|
||||||
|
{ slot-spec f } swap append >tuple
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: lookup-type-number ( word -- n )
|
||||||
|
global [ target-word ] bind type-number ;
|
||||||
|
|
||||||
|
: define-builtin ( symbol predicate slotspec -- )
|
||||||
|
>r dup make-inline >r
|
||||||
|
dup dup lookup-type-number "type" set-word-prop
|
||||||
|
dup f f builtin-class define-class
|
||||||
|
dup r> builtin-predicate
|
||||||
|
dup r> intern-slots 2dup "slots" set-word-prop
|
||||||
|
define-slots
|
||||||
|
register-builtin ;
|
||||||
|
|
||||||
|
H{ } clone typemap set
|
||||||
|
num-types get f <array> builtins set
|
||||||
|
|
||||||
|
! These symbols are needed by the code that executes below
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
{ "null" "kernel" }
|
||||||
|
} [ create drop ] assoc-each
|
||||||
|
|
||||||
|
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||||
|
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
|
"bignum" "math" create "bignum?" "math" create { } define-builtin
|
||||||
|
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
|
"tuple" "kernel" create "tuple?" "kernel" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"ratio" "math" create "ratio?" "math" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "integer" "math" }
|
||||||
|
"numerator"
|
||||||
|
1
|
||||||
|
{ "numerator" "math" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "integer" "math" }
|
||||||
|
"denominator"
|
||||||
|
2
|
||||||
|
{ "denominator" "math" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"float" "math" create "float?" "math" create { } define-builtin
|
||||||
|
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
|
"complex" "math" create "complex?" "math" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "real" "math" }
|
||||||
|
"real"
|
||||||
|
1
|
||||||
|
{ "real" "math" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "real" "math" }
|
||||||
|
"imaginary"
|
||||||
|
2
|
||||||
|
{ "imaginary" "math" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"f" "syntax" lookup "not" "kernel" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"array" "arrays" create "array?" "arrays" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"wrapper" "kernel" create "wrapper?" "kernel" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"wrapped"
|
||||||
|
1
|
||||||
|
{ "wrapped" "kernel" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"hashtable" "hashtables" create "hashtable?" "hashtables" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"count"
|
||||||
|
1
|
||||||
|
{ "hash-count" "hashtables.private" }
|
||||||
|
{ "set-hash-count" "hashtables.private" }
|
||||||
|
} {
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"deleted"
|
||||||
|
2
|
||||||
|
{ "hash-deleted" "hashtables.private" }
|
||||||
|
{ "set-hash-deleted" "hashtables.private" }
|
||||||
|
} {
|
||||||
|
{ "array" "arrays" }
|
||||||
|
"array"
|
||||||
|
3
|
||||||
|
{ "hash-array" "hashtables.private" }
|
||||||
|
{ "set-hash-array" "hashtables.private" }
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"vector" "vectors" create "vector?" "vectors" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"fill"
|
||||||
|
1
|
||||||
|
{ "length" "sequences" }
|
||||||
|
{ "set-fill" "growable" }
|
||||||
|
} {
|
||||||
|
{ "array" "arrays" }
|
||||||
|
"underlying"
|
||||||
|
2
|
||||||
|
{ "underlying" "growable" }
|
||||||
|
{ "set-underlying" "growable" }
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"string" "strings" create "string?" "strings" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"length"
|
||||||
|
1
|
||||||
|
{ "length" "sequences" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"sbuf" "sbufs" create "sbuf?" "sbufs" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"length"
|
||||||
|
1
|
||||||
|
{ "length" "sequences" }
|
||||||
|
{ "set-fill" "growable" }
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "string" "strings" }
|
||||||
|
"underlying"
|
||||||
|
2
|
||||||
|
{ "underlying" "growable" }
|
||||||
|
{ "set-underlying" "growable" }
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"quotation" "quotations" create "quotation?" "quotations" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"array"
|
||||||
|
1
|
||||||
|
{ "quotation-array" "quotations.private" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"dll" "alien" create "dll?" "alien" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "byte-array" "byte-arrays" }
|
||||||
|
"path"
|
||||||
|
1
|
||||||
|
{ "(dll-path)" "alien" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
}
|
||||||
|
define-builtin
|
||||||
|
|
||||||
|
"alien" "alien" create "alien?" "alien" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "c-ptr" "alien" }
|
||||||
|
"alien"
|
||||||
|
1
|
||||||
|
{ "underlying-alien" "alien" }
|
||||||
|
f
|
||||||
|
} {
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"expired?"
|
||||||
|
2
|
||||||
|
{ "expired?" "alien" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
}
|
||||||
|
define-builtin
|
||||||
|
|
||||||
|
"word" "words" create "word?" "words" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"name"
|
||||||
|
2
|
||||||
|
{ "word-name" "words" }
|
||||||
|
{ "set-word-name" "words" }
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"vocabulary"
|
||||||
|
3
|
||||||
|
{ "word-vocabulary" "words" }
|
||||||
|
{ "set-word-vocabulary" "words" }
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"def"
|
||||||
|
4
|
||||||
|
{ "word-def" "words" }
|
||||||
|
{ "set-word-def" "words.private" }
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"props"
|
||||||
|
5
|
||||||
|
{ "word-props" "words" }
|
||||||
|
{ "set-word-props" "words" }
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"?"
|
||||||
|
6
|
||||||
|
{ "compiled?" "words" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "fixnum" "math" }
|
||||||
|
"counter"
|
||||||
|
7
|
||||||
|
{ "profile-counter" "tools.profiler.private" }
|
||||||
|
{ "set-profile-counter" "tools.profiler.private" }
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"byte-array" "byte-arrays" create
|
||||||
|
"byte-array?" "byte-arrays" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"bit-array" "bit-arrays" create
|
||||||
|
"bit-array?" "bit-arrays" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"float-array" "float-arrays" create
|
||||||
|
"float-array?" "float-arrays" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
"curry" "kernel" create
|
||||||
|
"curry?" "kernel" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"obj"
|
||||||
|
1
|
||||||
|
{ "curry-obj" "kernel" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
{
|
||||||
|
{ "object" "kernel" }
|
||||||
|
"obj"
|
||||||
|
2
|
||||||
|
{ "curry-quot" "kernel" }
|
||||||
|
f
|
||||||
|
}
|
||||||
|
} define-builtin
|
||||||
|
|
||||||
|
"callstack" "kernel" create "callstack?" "kernel" create
|
||||||
|
{ } define-builtin
|
||||||
|
|
||||||
|
! Define general-t type, which is any object that is not f.
|
||||||
|
"general-t" "kernel" create
|
||||||
|
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
||||||
|
define-class
|
||||||
|
|
||||||
|
! Catch-all class for providing a default method.
|
||||||
|
"object" "kernel" create [ drop t ] "predicate" set-word-prop
|
||||||
|
"object" "kernel" create
|
||||||
|
builtins get [ ] subset f union-class define-class
|
||||||
|
|
||||||
|
! Class of objects with object tag
|
||||||
|
"hi-tag" "classes.private" create
|
||||||
|
builtins get num-tags get tail f union-class define-class
|
||||||
|
|
||||||
|
! Null class with no instances.
|
||||||
|
"null" "kernel" create [ drop f ] "predicate" set-word-prop
|
||||||
|
"null" "kernel" create { } f union-class define-class
|
||||||
|
|
||||||
|
! Create special tombstone values
|
||||||
|
"tombstone" "hashtables.private" create { } define-tuple-class
|
||||||
|
|
||||||
|
"((empty))" "hashtables.private" create
|
||||||
|
"tombstone" "hashtables.private" lookup f
|
||||||
|
2array >tuple 1quotation define-inline
|
||||||
|
|
||||||
|
"((tombstone))" "hashtables.private" create
|
||||||
|
"tombstone" "hashtables.private" lookup t
|
||||||
|
2array >tuple 1quotation define-inline
|
||||||
|
|
||||||
|
! Bump build number
|
||||||
|
"build" "kernel" create build 1+ 1quotation define-compound
|
||||||
|
|
@ -0,0 +1,43 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: bootstrap.stage1
|
||||||
|
USING: arrays debugger generic hashtables io assocs
|
||||||
|
kernel.private kernel math memory namespaces parser
|
||||||
|
prettyprint sequences vectors words system splitting
|
||||||
|
init io.files bootstrap.image bootstrap.image.private vocabs
|
||||||
|
vocabs.loader system ;
|
||||||
|
|
||||||
|
{ "resource:core" } vocab-roots set
|
||||||
|
|
||||||
|
"Bootstrap stage 1..." print flush
|
||||||
|
|
||||||
|
"resource:core/bootstrap/primitives.factor" run-file
|
||||||
|
|
||||||
|
! Create a boot quotation
|
||||||
|
[
|
||||||
|
! Rehash hashtables, since core/tools/image creates them
|
||||||
|
! using the host image's hashing algorithms
|
||||||
|
|
||||||
|
[ [ hashtable? ] instances [ rehash ] each ] %
|
||||||
|
|
||||||
|
\ boot ,
|
||||||
|
|
||||||
|
"math.integers" require
|
||||||
|
"memory" require
|
||||||
|
"io.streams.c" require
|
||||||
|
"vocabs.loader" require
|
||||||
|
"syntax" require
|
||||||
|
"bootstrap.layouts" require
|
||||||
|
|
||||||
|
[
|
||||||
|
"resource:core/bootstrap/stage2.factor"
|
||||||
|
dup ?resource-path exists? [
|
||||||
|
run-file
|
||||||
|
] [
|
||||||
|
"Cannot find " write write "." print
|
||||||
|
"Please move " write image write " to the same directory as the Factor sources," print
|
||||||
|
"and try again." print
|
||||||
|
1 exit
|
||||||
|
] if
|
||||||
|
] %
|
||||||
|
] [ ] make bootstrap-boot-quot set
|
||||||
|
|
@ -0,0 +1,83 @@
|
||||||
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: init command-line namespaces words debugger io
|
||||||
|
kernel.private math memory continuations kernel io.files
|
||||||
|
io.backend system parser vocabs sequences prettyprint
|
||||||
|
vocabs.loader combinators splitting source-files strings
|
||||||
|
definitions assocs ;
|
||||||
|
IN: bootstrap.stage2
|
||||||
|
|
||||||
|
! Wrap everything in a catch which starts a listener so
|
||||||
|
! you can see what went wrong, instead of dealing with a
|
||||||
|
! fep
|
||||||
|
[
|
||||||
|
vm file-name windows? [ >lower ".exe" ?tail drop ] when
|
||||||
|
".image" append "output-image" set-global
|
||||||
|
|
||||||
|
"math compiler tools help ui ui.tools io" "include" set-global
|
||||||
|
"" "exclude" set-global
|
||||||
|
|
||||||
|
parse-command-line
|
||||||
|
|
||||||
|
"Cross-referencing..." print flush
|
||||||
|
H{ } clone changed-words set-global
|
||||||
|
H{ } clone crossref set-global
|
||||||
|
xref-words
|
||||||
|
xref-sources
|
||||||
|
|
||||||
|
! Set dll paths
|
||||||
|
wince? [ "windows.ce" require ] when
|
||||||
|
winnt? [ "windows.nt" require ] when
|
||||||
|
|
||||||
|
[
|
||||||
|
! Compile everything if compiler is loaded
|
||||||
|
all-words [ changed-word ] each
|
||||||
|
|
||||||
|
"exclude" "include"
|
||||||
|
[ get-global " " split [ empty? not ] subset ] 2apply
|
||||||
|
seq-diff
|
||||||
|
[ "bootstrap." swap append require ] each
|
||||||
|
] no-parse-hook
|
||||||
|
|
||||||
|
init-io
|
||||||
|
init-stdio
|
||||||
|
|
||||||
|
changed-words get clear-assoc
|
||||||
|
|
||||||
|
"compile-errors" "generator" lookup [
|
||||||
|
f swap set-global
|
||||||
|
] when*
|
||||||
|
|
||||||
|
run-bootstrap-init
|
||||||
|
|
||||||
|
f error set-global
|
||||||
|
f error-continuation set-global
|
||||||
|
|
||||||
|
"deploy-vocab" get [
|
||||||
|
"tools.deploy" run
|
||||||
|
] [
|
||||||
|
"listener" require
|
||||||
|
"none" require
|
||||||
|
|
||||||
|
[
|
||||||
|
boot
|
||||||
|
do-init-hooks
|
||||||
|
[ parse-command-line ] try
|
||||||
|
[ run-user-init ] try
|
||||||
|
[ "run" get run ] try
|
||||||
|
stdio get [ stream-flush ] when*
|
||||||
|
] set-boot-quot
|
||||||
|
|
||||||
|
: count-words all-words swap subset length pprint ;
|
||||||
|
|
||||||
|
[ compiled? ] count-words " compiled words" print
|
||||||
|
[ symbol? ] count-words " symbol words" print
|
||||||
|
[ ] count-words " words total" print
|
||||||
|
|
||||||
|
"Bootstrapping is complete." print
|
||||||
|
"Now, you can run ./factor -i=" write
|
||||||
|
"output-image" get print flush
|
||||||
|
|
||||||
|
"output-image" get resource-path save-image-and-exit
|
||||||
|
] if
|
||||||
|
] [ error-hook get call "listener" run ] recover
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Bootstrap image generation
|
||||||
|
|
@ -0,0 +1,69 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: words sequences vocabs kernel ;
|
||||||
|
IN: bootstrap.syntax
|
||||||
|
|
||||||
|
"syntax" create-vocab
|
||||||
|
"resource:core" over set-vocab-root
|
||||||
|
f swap set-vocab-source-loaded?
|
||||||
|
|
||||||
|
{
|
||||||
|
"!"
|
||||||
|
"\""
|
||||||
|
"#!"
|
||||||
|
"("
|
||||||
|
":"
|
||||||
|
";"
|
||||||
|
"<PRIVATE"
|
||||||
|
"?{"
|
||||||
|
"BIN:"
|
||||||
|
"B{"
|
||||||
|
"C:"
|
||||||
|
"CHAR:"
|
||||||
|
"C{"
|
||||||
|
"DEFER:"
|
||||||
|
"F{"
|
||||||
|
"FORGET:"
|
||||||
|
"GENERIC#"
|
||||||
|
"GENERIC:"
|
||||||
|
"HEX:"
|
||||||
|
"HOOK:"
|
||||||
|
"H{"
|
||||||
|
"IN:"
|
||||||
|
"INSTANCE:"
|
||||||
|
"M:"
|
||||||
|
"MAIN:"
|
||||||
|
"MATH:"
|
||||||
|
"MIXIN:"
|
||||||
|
"OCT:"
|
||||||
|
"P\""
|
||||||
|
"POSTPONE:"
|
||||||
|
"PREDICATE:"
|
||||||
|
"PRIMITIVE:"
|
||||||
|
"PRIVATE>"
|
||||||
|
"SBUF\""
|
||||||
|
"SYMBOL:"
|
||||||
|
"TUPLE:"
|
||||||
|
"T{"
|
||||||
|
"UNION:"
|
||||||
|
"USE-IF:"
|
||||||
|
"USE:"
|
||||||
|
"USING:"
|
||||||
|
"V{"
|
||||||
|
"W{"
|
||||||
|
"["
|
||||||
|
"\\"
|
||||||
|
"]"
|
||||||
|
"delimiter"
|
||||||
|
"f"
|
||||||
|
"flushable"
|
||||||
|
"foldable"
|
||||||
|
"inline"
|
||||||
|
"parsing"
|
||||||
|
"t"
|
||||||
|
"{"
|
||||||
|
"}"
|
||||||
|
"CS{"
|
||||||
|
} [ "syntax" create drop ] each
|
||||||
|
|
||||||
|
"t" "syntax" lookup define-symbol
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading terminal-based developer tools in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1,19 @@
|
||||||
|
USING: kernel vocabs vocabs.loader sequences namespaces parser ;
|
||||||
|
|
||||||
|
{
|
||||||
|
"bootstrap.image"
|
||||||
|
"tools.annotations"
|
||||||
|
"tools.crossref"
|
||||||
|
"tools.deploy"
|
||||||
|
"tools.memory"
|
||||||
|
"tools.test"
|
||||||
|
"tools.time"
|
||||||
|
"tools.walker"
|
||||||
|
"editors"
|
||||||
|
} dup [ require ] each
|
||||||
|
|
||||||
|
global [ add-use ] bind
|
||||||
|
|
||||||
|
"bootstrap.compiler" vocab [
|
||||||
|
"tools.profiler" dup require use+
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading graphical user interface in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Loading graphical developer tools in stage 2 bootstrap
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
USING: kernel vocabs vocabs.loader sequences ;
|
||||||
|
|
||||||
|
{ "ui" "help" "tools" }
|
||||||
|
[ "bootstrap." swap append vocab ] all? [
|
||||||
|
"ui.tools" require
|
||||||
|
|
||||||
|
"ui.cocoa" vocab [
|
||||||
|
"ui.cocoa.tools" require
|
||||||
|
] when
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
USING: alien namespaces system combinators kernel sequences
|
||||||
|
vocabs vocabs.loader ;
|
||||||
|
|
||||||
|
"bootstrap.compiler" vocab [
|
||||||
|
"ui-backend" get [
|
||||||
|
{
|
||||||
|
{ [ macosx? ] [ "cocoa" ] }
|
||||||
|
{ [ windows? ] [ "windows" ] }
|
||||||
|
{ [ unix? ] [ "x11" ] }
|
||||||
|
} cond
|
||||||
|
] unless* "ui." swap append require
|
||||||
|
|
||||||
|
"ui.freetype" require
|
||||||
|
] when
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,31 @@
|
||||||
|
USING: arrays bit-arrays vectors strings sbufs
|
||||||
|
kernel help.markup help.syntax ;
|
||||||
|
IN: byte-arrays
|
||||||
|
|
||||||
|
ARTICLE: "byte-arrays" "Byte arrays"
|
||||||
|
"Byte arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are integers in the range 0-255, inclusive. Each element only uses one byte of storage, hence the name. The literal syntax is covered in " { $link "syntax-byte-arrays" } "."
|
||||||
|
$nl
|
||||||
|
"Byte array words are in the " { $vocab-link "byte-arrays" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Byte 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-byte-arrays" } "."
|
||||||
|
$nl
|
||||||
|
"Byte arrays form a class of objects."
|
||||||
|
{ $subsection byte-array }
|
||||||
|
{ $subsection byte-array? }
|
||||||
|
"There are several ways to construct byte arrays."
|
||||||
|
{ $subsection >byte-array }
|
||||||
|
{ $subsection <byte-array> } ;
|
||||||
|
|
||||||
|
ABOUT: "byte-arrays"
|
||||||
|
|
||||||
|
HELP: byte-array
|
||||||
|
{ $description "The class of byte arrays. See " { $link "syntax-byte-arrays" } " for syntax and " { $link "byte-arrays" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: <byte-array> ( n -- byte-array )
|
||||||
|
{ $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } }
|
||||||
|
{ $description "Creates a new byte array holding " { $snippet "n" } " bytes." } ;
|
||||||
|
|
||||||
|
HELP: >byte-array
|
||||||
|
{ $values { "seq" "a sequence" } { "byte-array" byte-array } }
|
||||||
|
{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." }
|
||||||
|
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
||||||
|
|
@ -0,0 +1,18 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: byte-arrays
|
||||||
|
USING: kernel kernel.private alien sequences
|
||||||
|
sequences.private math ;
|
||||||
|
|
||||||
|
M: byte-array clone (clone) ;
|
||||||
|
M: byte-array length array-capacity ;
|
||||||
|
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
|
||||||
|
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
|
||||||
|
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
|
||||||
|
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
|
||||||
|
M: byte-array new drop <byte-array> ;
|
||||||
|
|
||||||
|
M: byte-array equal?
|
||||||
|
over byte-array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
INSTANCE: byte-array sequence
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Efficient fixed-length byte arrays
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
collections
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,219 @@
|
||||||
|
USING: generic help.markup help.syntax kernel kernel.private
|
||||||
|
namespaces sequences words arrays layouts help effects math
|
||||||
|
layouts classes.private classes.union classes.mixin
|
||||||
|
classes.predicate ;
|
||||||
|
IN: classes
|
||||||
|
|
||||||
|
ARTICLE: "builtin-classes" "Built-in classes"
|
||||||
|
"Every object is an instance of to exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
|
||||||
|
$nl
|
||||||
|
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
|
||||||
|
{ $subsection type }
|
||||||
|
"Built-in type numbers can be converted to classes, and vice versa:"
|
||||||
|
{ $subsection type>class }
|
||||||
|
{ $subsection type-number }
|
||||||
|
"The set of built-in classes is a class:"
|
||||||
|
{ $subsection builtin-class }
|
||||||
|
{ $subsection builtin-class? }
|
||||||
|
"See " { $link "type-index" } " for a list of built-in classes." ;
|
||||||
|
|
||||||
|
ARTICLE: "class-operations" "Class operations"
|
||||||
|
"Set-theoretic operations on classes:"
|
||||||
|
{ $subsection class< }
|
||||||
|
{ $subsection class-and }
|
||||||
|
{ $subsection class-or }
|
||||||
|
{ $subsection classes-intersect? }
|
||||||
|
"Topological sort:"
|
||||||
|
{ $subsection sort-classes }
|
||||||
|
{ $subsection min-class }
|
||||||
|
"Low-level implementation detail:"
|
||||||
|
{ $subsection types }
|
||||||
|
{ $subsection flatten-class }
|
||||||
|
{ $subsection flatten-builtin-class }
|
||||||
|
{ $subsection flatten-union-class } ;
|
||||||
|
|
||||||
|
ARTICLE: "class-predicates" "Class predicate words"
|
||||||
|
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
|
||||||
|
$nl
|
||||||
|
"When it comes to predicates, the exceptional classes are:"
|
||||||
|
{ $table
|
||||||
|
{ "Class" "Predicate" "Explanation" }
|
||||||
|
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
|
||||||
|
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
|
||||||
|
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
|
||||||
|
{ { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
|
||||||
|
}
|
||||||
|
"The set of class predicate words is a class:"
|
||||||
|
{ $subsection predicate }
|
||||||
|
{ $subsection predicate? }
|
||||||
|
"A predicate word holds a reference to the class it is predicating over in the " { $snippet "\"predicating\"" } " word property." ;
|
||||||
|
|
||||||
|
ARTICLE: "classes" "Classes"
|
||||||
|
"Conceptually, a " { $snippet "class" } " is a set of objects whose members can be identified with a predicate, and on which generic words can specialize methods. Classes are organized into a general partial order, and an object may be an instance of more than one class."
|
||||||
|
$nl
|
||||||
|
"At the implementation level, a class is a word with certain word properties set."
|
||||||
|
$nl
|
||||||
|
"Words for working with classes are found in the " { $vocab-link "classes" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Classes themselves form a class:"
|
||||||
|
{ $subsection class? }
|
||||||
|
"You can ask an object for its class:"
|
||||||
|
{ $subsection class }
|
||||||
|
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
|
||||||
|
{ $subsection object }
|
||||||
|
{ $subsection null }
|
||||||
|
"Obtaining a list of all defined classes:"
|
||||||
|
{ $subsection classes }
|
||||||
|
"Other sorts of classes:"
|
||||||
|
{ $subsection "builtin-classes" }
|
||||||
|
{ $subsection "unions" }
|
||||||
|
{ $subsection "mixins" }
|
||||||
|
{ $subsection "predicates" }
|
||||||
|
"Classes can be inspected and operated upon:"
|
||||||
|
{ $subsection "class-operations" }
|
||||||
|
{ $see-also "class-index" } ;
|
||||||
|
|
||||||
|
ABOUT: "classes"
|
||||||
|
|
||||||
|
HELP: class
|
||||||
|
{ $values { "object" object } { "class" class } }
|
||||||
|
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
|
||||||
|
{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
|
||||||
|
{ $examples { $example "USE: classes" "1.0 class ." "float" } { $example "USE: classes" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
|
||||||
|
|
||||||
|
HELP: classes
|
||||||
|
{ $values { "seq" "a sequence of class words" } }
|
||||||
|
{ $description "Finds all class words in the dictionary." } ;
|
||||||
|
|
||||||
|
HELP: builtin-class
|
||||||
|
{ $class-description "The class of built-in classes." }
|
||||||
|
{ $examples
|
||||||
|
"The class of arrays is a built-in class:"
|
||||||
|
{ $example "USE: classes" "array builtin-class? ." "t" }
|
||||||
|
"However, a literal array is not a built-in class; it is not even a class:"
|
||||||
|
{ $example "USE: classes" "{ 1 2 3 } builtin-class? ." "f" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: tuple-class
|
||||||
|
{ $class-description "The class of tuple class words." }
|
||||||
|
{ $examples { $example "USE: classes\nTUPLE: name title first last ;\nname tuple-class? ." "t" } } ;
|
||||||
|
|
||||||
|
HELP: typemap
|
||||||
|
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
|
||||||
|
|
||||||
|
HELP: builtins
|
||||||
|
{ $var-description "Vector mapping type numbers to builtin class words." } ;
|
||||||
|
|
||||||
|
HELP: class<map
|
||||||
|
{ $var-description "Hashtable mapping each class to a set of classes which are contained in that class under the " { $link (class<) } " relation. The " { $link class< } " word uses this hashtable to avoid frequent expensive calls to " { $link (class<) } "." } ;
|
||||||
|
|
||||||
|
HELP: update-map
|
||||||
|
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
|
||||||
|
|
||||||
|
HELP: type>class
|
||||||
|
{ $values { "n" "a non-negative integer" } { "class" class } }
|
||||||
|
{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
|
||||||
|
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
|
||||||
|
|
||||||
|
HELP: predicate-word
|
||||||
|
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
|
||||||
|
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
|
||||||
|
|
||||||
|
HELP: define-predicate
|
||||||
|
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
|
||||||
|
{ $description
|
||||||
|
"Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
|
||||||
|
{ $list
|
||||||
|
{ "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
|
||||||
|
{ "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
|
||||||
|
{ "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
|
||||||
|
}
|
||||||
|
"These properties are used by method dispatch and the help system."
|
||||||
|
}
|
||||||
|
$low-level-note ;
|
||||||
|
|
||||||
|
HELP: superclass
|
||||||
|
{ $values { "class" class } { "super" class } }
|
||||||
|
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
|
||||||
|
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate and tuple classes." } ;
|
||||||
|
|
||||||
|
HELP: members
|
||||||
|
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
|
||||||
|
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
|
||||||
|
|
||||||
|
HELP: flatten-union-class
|
||||||
|
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
|
||||||
|
{ $description "Outputs the set of classes whose union is equal to " { $snippet "class" } ". Unions are expanded recursively so the output assoc does not contain any union classes. However, it may contain predicate classes whose superclasses are unions." } ;
|
||||||
|
|
||||||
|
HELP: flatten-builtin-class
|
||||||
|
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
|
||||||
|
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
|
||||||
|
|
||||||
|
HELP: flatten-class
|
||||||
|
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
|
||||||
|
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
|
||||||
|
|
||||||
|
HELP: types
|
||||||
|
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
|
||||||
|
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
|
||||||
|
|
||||||
|
HELP: class-empty?
|
||||||
|
{ $values { "class" "a class" } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if a class is a union class with no members." }
|
||||||
|
{ $examples { $example "USE: classes" "null class-empty? ." "t" } } ;
|
||||||
|
|
||||||
|
HELP: (class<)
|
||||||
|
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||||
|
{ $description "Performs the calculation for " { $link class< } ". There is never any reason to call this word from user code since " { $link class< } " outputs identical values and caches results for better performance." } ;
|
||||||
|
|
||||||
|
HELP: class<
|
||||||
|
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
|
||||||
|
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
|
||||||
|
|
||||||
|
HELP: sort-classes
|
||||||
|
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
|
||||||
|
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
|
||||||
|
|
||||||
|
{ sort-classes methods order } related-words
|
||||||
|
|
||||||
|
HELP: lookup-union
|
||||||
|
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
|
||||||
|
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
|
||||||
|
|
||||||
|
{ class-and class-or lookup-union } related-words
|
||||||
|
|
||||||
|
HELP: class-or
|
||||||
|
{ $values { "class1" class } { "class2" class } { "class" class } }
|
||||||
|
{ $description "Outputs the smallest known class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
|
||||||
|
|
||||||
|
HELP: class-and
|
||||||
|
{ $values { "class1" class } { "class2" class } { "class" class } }
|
||||||
|
{ $description "Outputs the largest known class contained in both " { $snippet "class1" } " and " { $snippet "class2" } ". If the intersection is non-empty but no union class with those exact members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
|
||||||
|
|
||||||
|
HELP: classes-intersect?
|
||||||
|
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
|
||||||
|
|
||||||
|
HELP: min-class
|
||||||
|
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
|
||||||
|
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
|
||||||
|
|
||||||
|
HELP: define-class
|
||||||
|
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
|
||||||
|
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
|
||||||
|
$low-level-note ;
|
||||||
|
|
||||||
|
: $predicate ( element -- )
|
||||||
|
{ { "object" object } { "?" "a boolean" } } $values
|
||||||
|
[
|
||||||
|
"Tests if the object is an instance of the " ,
|
||||||
|
first "predicating" word-prop \ $link swap 2array ,
|
||||||
|
" class." ,
|
||||||
|
] { } make $description ;
|
||||||
|
|
||||||
|
M: predicate word-help* drop \ $predicate ;
|
||||||
|
|
||||||
|
HELP: $predicate
|
||||||
|
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
|
||||||
|
{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;
|
||||||
|
|
@ -0,0 +1,179 @@
|
||||||
|
USING: alien arrays definitions generic assocs hashtables io
|
||||||
|
kernel math namespaces parser prettyprint sequences strings
|
||||||
|
tools.test vectors words quotations classes io.streams.string
|
||||||
|
classes.private classes.union classes.mixin classes.predicate
|
||||||
|
vectors ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
|
H{ } "s" set
|
||||||
|
|
||||||
|
[ ] [ 1 2 "s" get push-at ] unit-test
|
||||||
|
[ 1 ] [ 2 "s" get at first ] unit-test
|
||||||
|
[ ] [ 1 2 "s" get pop-at ] unit-test
|
||||||
|
[ t ] [ 2 "s" get at empty? ] unit-test
|
||||||
|
|
||||||
|
[ object ] [ object object class-and ] unit-test
|
||||||
|
[ fixnum ] [ fixnum object class-and ] unit-test
|
||||||
|
[ fixnum ] [ object fixnum class-and ] unit-test
|
||||||
|
[ fixnum ] [ fixnum fixnum class-and ] unit-test
|
||||||
|
[ fixnum ] [ fixnum integer class-and ] unit-test
|
||||||
|
[ fixnum ] [ integer fixnum class-and ] unit-test
|
||||||
|
[ null ] [ vector fixnum class-and ] unit-test
|
||||||
|
[ number ] [ number object class-and ] unit-test
|
||||||
|
[ number ] [ object number class-and ] unit-test
|
||||||
|
[ null ] [ slice reversed class-and ] unit-test
|
||||||
|
|
||||||
|
TUPLE: first-one ;
|
||||||
|
TUPLE: second-one ;
|
||||||
|
UNION: both first-one union-class ;
|
||||||
|
|
||||||
|
[ t ] [ both tuple classes-intersect? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ \ fixnum \ integer class< ] unit-test
|
||||||
|
[ t ] [ \ fixnum \ fixnum class< ] unit-test
|
||||||
|
[ f ] [ \ integer \ fixnum class< ] unit-test
|
||||||
|
[ t ] [ \ integer \ object class< ] unit-test
|
||||||
|
[ f ] [ \ integer \ null class< ] unit-test
|
||||||
|
[ t ] [ \ null \ object class< ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ \ generic \ compound class< ] unit-test
|
||||||
|
[ f ] [ \ compound \ generic class< ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ \ reversed \ slice class< ] unit-test
|
||||||
|
[ f ] [ \ slice \ reversed class< ] unit-test
|
||||||
|
|
||||||
|
PREDICATE: word no-docs "documentation" word-prop not ;
|
||||||
|
|
||||||
|
UNION: no-docs-union no-docs integer ;
|
||||||
|
|
||||||
|
[ t ] [ no-docs no-docs-union class< ] unit-test
|
||||||
|
[ f ] [ no-docs-union no-docs class< ] unit-test
|
||||||
|
|
||||||
|
TUPLE: a ;
|
||||||
|
TUPLE: b ;
|
||||||
|
UNION: c a b ;
|
||||||
|
|
||||||
|
[ t ] [ \ c \ tuple class< ] unit-test
|
||||||
|
[ f ] [ \ tuple \ c class< ] unit-test
|
||||||
|
|
||||||
|
DEFER: bah
|
||||||
|
FORGET: bah
|
||||||
|
UNION: bah fixnum alien ;
|
||||||
|
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||||
|
|
||||||
|
! Test generic see and parsing
|
||||||
|
[ "IN: temporary\nSYMBOL: bah\n\nUNION: bah fixnum alien ;\n" ]
|
||||||
|
[ [ \ bah see ] string-out ] unit-test
|
||||||
|
|
||||||
|
! Test redefinition of classes
|
||||||
|
UNION: union-1 fixnum float ;
|
||||||
|
|
||||||
|
GENERIC: generic-update-test ( x -- y )
|
||||||
|
|
||||||
|
M: union-1 generic-update-test drop "union-1" ;
|
||||||
|
|
||||||
|
[ f ] [ bignum union-1 class< ] unit-test
|
||||||
|
[ t ] [ union-1 number class< ] unit-test
|
||||||
|
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
|
||||||
|
|
||||||
|
[ union-1 ] [ fixnum float class-or ] unit-test
|
||||||
|
|
||||||
|
"IN: temporary UNION: union-1 rational array ;" eval
|
||||||
|
|
||||||
|
do-parse-hook
|
||||||
|
|
||||||
|
[ t ] [ bignum union-1 class< ] unit-test
|
||||||
|
[ f ] [ union-1 number class< ] unit-test
|
||||||
|
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
|
||||||
|
|
||||||
|
[ object ] [ fixnum float class-or ] unit-test
|
||||||
|
|
||||||
|
"IN: temporary PREDICATE: integer union-1 even? ;" eval
|
||||||
|
|
||||||
|
do-parse-hook
|
||||||
|
|
||||||
|
[ f ] [ union-1 union-class? ] unit-test
|
||||||
|
[ t ] [ union-1 predicate-class? ] unit-test
|
||||||
|
[ "union-1" ] [ 8 generic-update-test ] unit-test
|
||||||
|
[ -7 generic-update-test ] unit-test-fails
|
||||||
|
|
||||||
|
! Test mixins
|
||||||
|
MIXIN: sequence-mixin
|
||||||
|
|
||||||
|
INSTANCE: array sequence-mixin
|
||||||
|
INSTANCE: vector sequence-mixin
|
||||||
|
INSTANCE: slice sequence-mixin
|
||||||
|
|
||||||
|
MIXIN: assoc-mixin
|
||||||
|
|
||||||
|
INSTANCE: hashtable assoc-mixin
|
||||||
|
|
||||||
|
GENERIC: collection-size ( x -- y )
|
||||||
|
|
||||||
|
M: sequence-mixin collection-size length ;
|
||||||
|
|
||||||
|
M: assoc-mixin collection-size assoc-size ;
|
||||||
|
|
||||||
|
[ t ] [ array sequence-mixin class< ] unit-test
|
||||||
|
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
|
||||||
|
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
|
||||||
|
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
|
||||||
|
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
|
||||||
|
|
||||||
|
! Test mixing in of new classes after the fact
|
||||||
|
MIXIN: mx1
|
||||||
|
|
||||||
|
INSTANCE: integer mx1
|
||||||
|
|
||||||
|
[ t ] [ integer mx1 class< ] unit-test
|
||||||
|
[ t ] [ mx1 integer class< ] unit-test
|
||||||
|
[ t ] [ mx1 number class< ] unit-test
|
||||||
|
|
||||||
|
"INSTANCE: array mx1" eval
|
||||||
|
|
||||||
|
[ t ] [ array mx1 class< ] unit-test
|
||||||
|
[ f ] [ mx1 number class< ] unit-test
|
||||||
|
|
||||||
|
[ mx1 ] [ array integer class-or ] unit-test
|
||||||
|
|
||||||
|
\ mx1 forget
|
||||||
|
|
||||||
|
[ f ] [ array integer class-or mx1 = ] unit-test
|
||||||
|
|
||||||
|
! Empty unions were causing problems
|
||||||
|
GENERIC: empty-union-test
|
||||||
|
|
||||||
|
UNION: empty-union-1 ;
|
||||||
|
|
||||||
|
M: empty-union-1 empty-union-test ;
|
||||||
|
|
||||||
|
UNION: empty-union-2 ;
|
||||||
|
|
||||||
|
M: empty-union-2 empty-union-test ;
|
||||||
|
|
||||||
|
! Redefining a class didn't update containing unions
|
||||||
|
UNION: redefine-bug-1 fixnum ;
|
||||||
|
|
||||||
|
UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
||||||
|
|
||||||
|
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
|
||||||
|
[ t ] [ quotation redefine-bug-2 class< ] unit-test
|
||||||
|
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
|
||||||
|
|
||||||
|
"IN: temporary UNION: redefine-bug-1 bignum ;" eval
|
||||||
|
|
||||||
|
[ t ] [ bignum redefine-bug-1 class< ] unit-test
|
||||||
|
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
|
||||||
|
[ t ] [ bignum redefine-bug-2 class< ] unit-test
|
||||||
|
[ f ] [ fixnum quotation class-or redefine-bug-2 eq? ] unit-test
|
||||||
|
[ redefine-bug-2 ] [ bignum quotation class-or ] unit-test
|
||||||
|
|
||||||
|
! Another issue similar to the above
|
||||||
|
UNION: forget-class-bug-1 integer ;
|
||||||
|
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
|
||||||
|
|
||||||
|
FORGET: forget-class-bug-1
|
||||||
|
FORGET: forget-class-bug-2
|
||||||
|
|
||||||
|
[ t ] [ integer dll class-or interned? ] unit-test
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue