Compare commits
No commits in common. "0.74" and "master" have entirely different histories.
|
|
@ -0,0 +1,14 @@
|
|||
;; Per-directory local variables for GNU Emacs 23 and later.
|
||||
((c++-mode . ((c-basic-offset . 2)
|
||||
(show-trailing-whitespace . t)
|
||||
(indicate-empty-lines . t)
|
||||
(indent-tabs-mode . nil)
|
||||
(eval . (progn
|
||||
(c-set-offset 'innamespace 0)
|
||||
(c-set-offset 'topmost-intro 0)
|
||||
(c-set-offset 'cpp-macro-cont '++)
|
||||
(c-set-offset 'case-label '+)
|
||||
(c-set-offset 'member-init-intro '++)
|
||||
(c-set-offset 'statement-cont '++)
|
||||
(c-set-offset 'arglist-intro '++)))))
|
||||
(factor-mode . ((factor-block-offset . 4))))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
*.factor text eol=lf
|
||||
*.html text eol=lf
|
||||
misc/vim/*/*/generated.vim linguist-generated
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
*#*#
|
||||
*.*.marks
|
||||
*.RES
|
||||
*.a
|
||||
*.bak
|
||||
*.dll
|
||||
*.dylib
|
||||
*.exe
|
||||
*.exp
|
||||
*.gch*
|
||||
*.image
|
||||
*.lib
|
||||
*.o
|
||||
*.obj
|
||||
*.res
|
||||
*.s
|
||||
*.so
|
||||
*~
|
||||
.#*
|
||||
.*.swm
|
||||
.*.swn
|
||||
.*.swo
|
||||
.*.swp
|
||||
.DS_Store
|
||||
.gdb_history
|
||||
/factor
|
||||
/logs
|
||||
/work
|
||||
Factor.app/Contents/MacOS/factor
|
||||
Factor.app/Contents/_CodeSignature
|
||||
a.out
|
||||
checksums.txt
|
||||
factor.com
|
||||
factor.image.fresh
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
language: cpp
|
||||
compiler:
|
||||
- clang
|
||||
- gcc
|
||||
os:
|
||||
- linux
|
||||
- osx
|
||||
sudo: required
|
||||
dist: trusty
|
||||
group: deprecated-2017Q4
|
||||
services:
|
||||
- postgresql
|
||||
- redis-server
|
||||
branches:
|
||||
except:
|
||||
- clean-windows-x86-64
|
||||
- clean-windows-x86-32
|
||||
- clean-linux-x86-64
|
||||
- clean-linux-x86-32
|
||||
- clean-macosx-x86-64
|
||||
- clean-macosx-x86-32
|
||||
addons:
|
||||
apt:
|
||||
packages:
|
||||
- links
|
||||
- libblas-dev
|
||||
- libmagic-dev
|
||||
- libsnappy-dev
|
||||
- libzmq-dev
|
||||
- libpq-dev
|
||||
- cmake
|
||||
- libaio-dev
|
||||
- libsnappy-dev
|
||||
- libgtk2.0-dev
|
||||
- gtk2-engines-pixbuf
|
||||
before_install:
|
||||
- uname -s
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export HOMEBREW_NO_AUTO_UPDATE=1 ; fi # Don't let homebrew upgrade itself
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/mpapis.asc | gpg --import - ; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://rvm.io/pkuczynski.asc | gpg --import - ; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307
|
||||
#- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm reload ; fi # for homebrew to have 2.6.3, which takes too long. instead we just use HOMEBREW_NO_AUTO_UPDATE=1
|
||||
#- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm install ruby-2.6.3 ; fi # for homebrew
|
||||
#- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm use 2.6 ; fi # for homebrew
|
||||
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then ./build.sh deps-macosx ; else ./build.sh deps-apt-get ; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions snappy > /dev/null || brew install snappy; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions cmake > /dev/null || brew install cmake; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions libmagic > /dev/null || brew install libmagic; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions memcached > /dev/null || brew install memcached; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions redis > /dev/null || brew install redis; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions zeromq > /dev/null || brew install zeromq; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew ls --versions postgresql > /dev/null || brew install postgresql; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start redis; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start postgresql; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi
|
||||
- if [[ "$TRAVIS_OS_NAME" != "windows" ]]; then
|
||||
wget https://github.com/vmt/udis86/archive/v1.7.2.tar.gz && tar xzvf v1.7.2.tar.gz &&
|
||||
( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) &&
|
||||
( [[ "$TRAVIS_OS_NAME" != "osx" ]] && sudo ldconfig || true );
|
||||
fi
|
||||
- git remote set-branches --add origin master
|
||||
- git remote set-branches --add origin clean-windows-x86-64
|
||||
- git remote set-branches --add origin clean-windows-x86-32
|
||||
- git remote set-branches --add origin clean-linux-x86-64
|
||||
- git remote set-branches --add origin clean-linux-x86-32
|
||||
- git remote set-branches --add origin clean-macosx-x86-64
|
||||
- git remote set-branches --add origin clean-macosx-x86-32
|
||||
- git fetch # so we can see which vocabs changed versus origin/master...
|
||||
script:
|
||||
- echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, TRAVIS_PULL_REQUEST_BRANCH=$TRAVIS_PULL_REQUEST_BRANCH"
|
||||
- export CI_BRANCH="${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}"
|
||||
- echo "CI_BRANCH=${CI_BRANCH}"
|
||||
- DEBUG=1 ./build.sh net-bootstrap < /dev/null
|
||||
- "./factor -e='USING: memory vocabs.hierarchy tools.test namespaces ; \"zealot\" load f long-unit-tests-enabled? set-global save'"
|
||||
- './factor -run=zealot.cli-changed-vocabs'
|
||||
- './factor -run=tools.test `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`'
|
||||
- './factor -run=zealot.help-lint `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`'
|
||||
- "./factor -e='USING: modern.paths tools.test sequences system kernel math random ; core-vocabs os macosx? [ dup length 3 /i sample ] when [ test ] each'"
|
||||
51
CHANGES.txt
51
CHANGES.txt
|
|
@ -1,51 +0,0 @@
|
|||
Factor 0.74:
|
||||
------------
|
||||
|
||||
C library interface ported to Linux/PPC and Mac OS X.
|
||||
|
||||
Developer's handbook rewritten to be more up to date and complete.
|
||||
|
||||
Added the sequences vocabulary that unifies code for working with lists,
|
||||
vectors, strings, and string buffers. There are many changes, and most
|
||||
of the old type-specific words such as vector-nth and string-map are
|
||||
gone.
|
||||
|
||||
Added the matrices vocabulary for working with mathematical vectors and
|
||||
matrices.
|
||||
|
||||
Added two words for modular arithmetic in the math vocabulary: mod-inv
|
||||
and ^mod.
|
||||
|
||||
Added HTTP client API supporting GET and POST requests in the
|
||||
http-client vocabulary.
|
||||
|
||||
Removed some inspection words: vocabs. words. usages. Now, just put a
|
||||
space before the . and write vocabs . words . usages .
|
||||
|
||||
Redefining words that are used by compiled words automatically
|
||||
decompiles the compiled words. This fixes the problem of new definitions
|
||||
not taking effect. In a future release, there will be automatic
|
||||
recompilation, rather than decompilation.
|
||||
|
||||
As a result of the previous change, there is now a cross-referencing
|
||||
database, and the usages word lists indirect dependencies and is much
|
||||
faster. The usage word behaves like the old usages, and lists direct
|
||||
dependencies only.
|
||||
|
||||
The dump word in the dump vocabulary prints the memory bytes comprising
|
||||
an object. The dump* word prints the bytes at an arbitrary address.
|
||||
|
||||
New words in words vocabulary for inspecting classes and methods:
|
||||
classes implements.
|
||||
|
||||
The Unix I/O code was rewritten in Factor using the C library interface.
|
||||
Many new features will be added in future releases, such as socket
|
||||
timeouts and Unicode character encodings.
|
||||
|
||||
Lazy lists and parser combinators library in contrib/parser-combinators/
|
||||
(Chris Double).
|
||||
|
||||
Quotations containing \ foo are prettyprinted in that form.
|
||||
|
||||
The watch word now causes annotated words to dump the stack, in addition
|
||||
to printing a log message.
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
<?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>Factor.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>CFBundleVersion</key>
|
||||
<string>0.99</string>
|
||||
<key>NSHumanReadableCopyright</key>
|
||||
<string>Copyright © 2003-2018 Factor developers</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>
|
||||
<key>NSHighResolutionCapable</key>
|
||||
<true/>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
@ -0,0 +1,282 @@
|
|||
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
|
||||
<document type="com.apple.InterfaceBuilder3.Cocoa.XIB" version="3.0" toolsVersion="10116" systemVersion="15E65" targetRuntime="MacOSX.Cocoa" propertyAccessControl="none">
|
||||
<dependencies>
|
||||
<deployment version="1050" identifier="macosx"/>
|
||||
<plugIn identifier="com.apple.InterfaceBuilder.CocoaPlugin" version="10116"/>
|
||||
</dependencies>
|
||||
<objects>
|
||||
<customObject id="-2" userLabel="File's Owner" customClass="NSApplication"/>
|
||||
<customObject id="-1" userLabel="First Responder" customClass="FirstResponder"/>
|
||||
<customObject id="-3" userLabel="Application" customClass="NSObject"/>
|
||||
<menu title="Factor.app:Contents:Resources:English.lproj:MenuBar" systemMenu="main" id="29" userLabel="MainMenu">
|
||||
<items>
|
||||
<menuItem title="Factor" id="56">
|
||||
<menu key="submenu" title="Factor" systemMenu="apple" id="57">
|
||||
<items>
|
||||
<menuItem title="About Factor" id="58">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<connections>
|
||||
<action selector="orderFrontStandardAboutPanel:" target="-2" id="142"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="236">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Run Factor Source…" keyEquivalent="o" id="366">
|
||||
<modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="runFactorFile:" target="-1" id="rgF-Ks-Gn8"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Save Factor Image" keyEquivalent="s" id="368">
|
||||
<modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="saveFactorImage:" target="-1" id="Iu7-Jk-Gn3"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Save Factor Image As…" keyEquivalent="S" id="369">
|
||||
<modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="saveFactorImageAs:" target="-1" id="YdH-jx-wV1"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="365"/>
|
||||
<menuItem title="Services" id="131">
|
||||
<menu key="submenu" title="Services" systemMenu="services" id="130"/>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="144">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Hide Factor" keyEquivalent="h" id="134">
|
||||
<connections>
|
||||
<action selector="hide:" target="-2" id="152"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Hide Others" keyEquivalent="h" id="145">
|
||||
<modifierMask key="keyEquivalentModifierMask" option="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="hideOtherApplications:" target="-2" id="146"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Show All" id="150">
|
||||
<connections>
|
||||
<action selector="unhideAllApplications:" target="-2" id="153"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="149">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Quit Factor" keyEquivalent="q" id="136">
|
||||
<connections>
|
||||
<action selector="terminate:" target="-2" id="139"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="File" id="343">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<menu key="submenu" title="File" id="344">
|
||||
<items>
|
||||
<menuItem title="New" keyEquivalent="n" id="345">
|
||||
<connections>
|
||||
<action selector="newDocument:" target="-1" id="358"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Open…" keyEquivalent="o" id="346">
|
||||
<connections>
|
||||
<action selector="openDocument:" target="-1" id="359"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="348"/>
|
||||
<menuItem title="Close" keyEquivalent="w" id="349">
|
||||
<connections>
|
||||
<action selector="performClose:" target="-1" id="360"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Save" keyEquivalent="s" id="350">
|
||||
<connections>
|
||||
<action selector="saveDocument:" target="-1" id="361"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Save As…" keyEquivalent="S" id="351">
|
||||
<connections>
|
||||
<action selector="saveDocumentAs:" target="-1" id="362"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Revert" id="352">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<connections>
|
||||
<action selector="revertDocumentToSaved:" target="-1" id="363"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Edit" id="304">
|
||||
<menu key="submenu" title="Edit" id="305">
|
||||
<items>
|
||||
<menuItem title="Undo" keyEquivalent="z" id="306">
|
||||
<connections>
|
||||
<action selector="undo:" target="-1" id="332"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Redo" keyEquivalent="Z" id="307">
|
||||
<connections>
|
||||
<action selector="redo:" target="-1" id="333"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="308">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Cut" keyEquivalent="x" id="309">
|
||||
<connections>
|
||||
<action selector="cut:" target="-1" id="341"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Copy" keyEquivalent="c" id="310">
|
||||
<connections>
|
||||
<action selector="copy:" target="-1" id="335"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Paste" keyEquivalent="v" id="311">
|
||||
<connections>
|
||||
<action selector="paste:" target="-1" id="336"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Delete" id="313">
|
||||
<connections>
|
||||
<action selector="delete:" target="-1" id="337"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Select All" keyEquivalent="a" id="314">
|
||||
<connections>
|
||||
<action selector="selectAll:" target="-1" id="338"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="315">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Find" id="316">
|
||||
<menu key="submenu" title="Find" id="326">
|
||||
<items>
|
||||
<menuItem title="Find…" tag="1" keyEquivalent="f" id="327"/>
|
||||
<menuItem title="Find Next" tag="2" keyEquivalent="g" id="328"/>
|
||||
<menuItem title="Find Previous" tag="3" keyEquivalent="G" id="329"/>
|
||||
<menuItem title="Use Selection for Find" tag="7" keyEquivalent="e" id="330"/>
|
||||
<menuItem title="Jump to Selection" keyEquivalent="j" id="331"/>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Spelling" id="317">
|
||||
<menu key="submenu" title="Spelling" id="322">
|
||||
<items>
|
||||
<menuItem title="Spelling…" keyEquivalent=":" id="323"/>
|
||||
<menuItem title="Check Spelling" keyEquivalent=";" id="324"/>
|
||||
<menuItem title="Check Spelling as You Type" id="325"/>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Speech" id="318">
|
||||
<menu key="submenu" title="Speech" id="319">
|
||||
<items>
|
||||
<menuItem title="Start Speaking" id="320"/>
|
||||
<menuItem title="Stop Speaking" id="321"/>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Tools" id="283">
|
||||
<menu key="submenu" title="Tools" id="284">
|
||||
<items>
|
||||
<menuItem title="Show Listener" keyEquivalent="l" id="286">
|
||||
<connections>
|
||||
<action selector="showFactorListener:" target="-1" id="r8I-gi-bmO"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="New Listener" keyEquivalent="L" id="287">
|
||||
<modifierMask key="keyEquivalentModifierMask" shift="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="newFactorListener:" target="-1" id="7yk-oP-H5Z"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="290">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Show Browser" keyEquivalent="b" id="288">
|
||||
<connections>
|
||||
<action selector="showFactorBrowser:" target="-1" id="g0e-dO-s7I"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="New Browser" keyEquivalent="B" id="289">
|
||||
<modifierMask key="keyEquivalentModifierMask" shift="YES" command="YES"/>
|
||||
<connections>
|
||||
<action selector="newFactorBrowser:" target="-1" id="cLP-Ug-xfc"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="PMQ-EN-0tV">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Switch Theme" id="Wvq-ot-R3p">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<menu key="submenu" title="Switch Theme" id="HqQ-K2-6Sn">
|
||||
<items>
|
||||
<menuItem title="Light" id="dSP-rb-Ak9">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<connections>
|
||||
<action selector="switchLightTheme:" target="-1" id="Y29-I0-nL0"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Dark" id="hBk-Ue-CIf">
|
||||
<modifierMask key="keyEquivalentModifierMask"/>
|
||||
<connections>
|
||||
<action selector="switchDarkTheme:" target="-1" id="2ug-u3-tEU"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Window" id="19">
|
||||
<menu key="submenu" title="Window" systemMenu="window" id="24">
|
||||
<items>
|
||||
<menuItem title="Minimize" keyEquivalent="m" id="23">
|
||||
<connections>
|
||||
<action selector="performMiniaturize:" target="-1" id="37"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem title="Zoom" id="239">
|
||||
<connections>
|
||||
<action selector="performZoom:" target="-1" id="240"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
<menuItem isSeparatorItem="YES" id="92">
|
||||
<modifierMask key="keyEquivalentModifierMask" command="YES"/>
|
||||
</menuItem>
|
||||
<menuItem title="Bring All to Front" id="5">
|
||||
<connections>
|
||||
<action selector="arrangeInFront:" target="-1" id="39"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
<menuItem title="Help" id="103">
|
||||
<menu key="submenu" title="Help" id="106">
|
||||
<items>
|
||||
<menuItem title="Factor Help" keyEquivalent="?" id="111">
|
||||
<connections>
|
||||
<action selector="showFactorBrowser:" target="-1" id="Ddd-ic-q9J"/>
|
||||
</connections>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</menuItem>
|
||||
</items>
|
||||
</menu>
|
||||
</objects>
|
||||
</document>
|
||||
Binary file not shown.
|
|
@ -0,0 +1,32 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBClasses</key>
|
||||
<array>
|
||||
<dict>
|
||||
<key>ACTIONS</key>
|
||||
<dict>
|
||||
<key>newFactorWorkspace</key>
|
||||
<string>id</string>
|
||||
<key>runFactorFile</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImage</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImageAs</key>
|
||||
<string>id</string>
|
||||
<key>showFactorHelp</key>
|
||||
<string>id</string>
|
||||
</dict>
|
||||
<key>CLASS</key>
|
||||
<string>FirstResponder</string>
|
||||
<key>LANGUAGE</key>
|
||||
<string>ObjC</string>
|
||||
<key>SUPERCLASS</key>
|
||||
<string>NSObject</string>
|
||||
</dict>
|
||||
</array>
|
||||
<key>IBVersion</key>
|
||||
<string>1</string>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBFramework Version</key>
|
||||
<string>677</string>
|
||||
<key>IBOldestOS</key>
|
||||
<integer>5</integer>
|
||||
<key>IBOpenObjects</key>
|
||||
<array>
|
||||
<integer>293</integer>
|
||||
</array>
|
||||
<key>IBSystem Version</key>
|
||||
<string>9J61</string>
|
||||
<key>targetFramework</key>
|
||||
<string>IBCocoaFramework</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,272 @@
|
|||
ifdef CONFIG
|
||||
VERSION = 0.99
|
||||
GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`)
|
||||
BUNDLE = Factor.app
|
||||
DEBUG ?= 0
|
||||
REPRODUCIBLE ?= 0
|
||||
|
||||
# gmake's default CXX is g++, we prefer c++
|
||||
SHELL_CXX = $(shell printenv CXX)
|
||||
ifeq ($(SHELL_CXX),)
|
||||
CXX=c++
|
||||
else
|
||||
CXX=$(SHELL_CXX)
|
||||
endif
|
||||
|
||||
XCODE_PATH ?= /Applications/Xcode.app
|
||||
MACOSX_32_SDK ?= MacOSX10.11.sdk
|
||||
MACOSX_SDK ?= MacOSX10.13.sdk
|
||||
|
||||
include $(CONFIG)
|
||||
|
||||
CFLAGS += -Wall \
|
||||
-pedantic \
|
||||
-DFACTOR_VERSION="$(VERSION)" \
|
||||
-DFACTOR_GIT_LABEL="$(GIT_LABEL)" \
|
||||
$(SITE_CFLAGS)
|
||||
|
||||
CXXFLAGS += -std=c++11
|
||||
|
||||
ifneq ($(DEBUG), 0)
|
||||
CFLAGS += -g -DFACTOR_DEBUG
|
||||
else
|
||||
CFLAGS += -O3
|
||||
endif
|
||||
|
||||
ifneq ($(REPRODUCIBLE), 0)
|
||||
CFLAGS += -DFACTOR_REPRODUCIBLE
|
||||
endif
|
||||
|
||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||
EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
|
||||
CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
|
||||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm/aging_collector.o \
|
||||
vm/alien.o \
|
||||
vm/arrays.o \
|
||||
vm/bignum.o \
|
||||
vm/byte_arrays.o \
|
||||
vm/callbacks.o \
|
||||
vm/callstack.o \
|
||||
vm/code_blocks.o \
|
||||
vm/code_heap.o \
|
||||
vm/compaction.o \
|
||||
vm/contexts.o \
|
||||
vm/data_heap.o \
|
||||
vm/data_heap_checker.o \
|
||||
vm/debug.o \
|
||||
vm/dispatch.o \
|
||||
vm/entry_points.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
vm/full_collector.o \
|
||||
vm/gc.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/instruction_operands.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/math.o \
|
||||
vm/mvm.o \
|
||||
vm/nursery_collector.o \
|
||||
vm/object_start_map.o \
|
||||
vm/objects.o \
|
||||
vm/primitives.o \
|
||||
vm/quotations.o \
|
||||
vm/run.o \
|
||||
vm/safepoints.o \
|
||||
vm/sampling_profiler.o \
|
||||
vm/strings.o \
|
||||
vm/to_tenured_collector.o \
|
||||
vm/tuples.o \
|
||||
vm/utilities.o \
|
||||
vm/vm.o \
|
||||
vm/words.o
|
||||
|
||||
MASTER_HEADERS = $(PLAF_MASTER_HEADERS) \
|
||||
vm/assert.hpp \
|
||||
vm/debug.hpp \
|
||||
vm/layouts.hpp \
|
||||
vm/platform.hpp \
|
||||
vm/primitives.hpp \
|
||||
vm/segments.hpp \
|
||||
vm/gc_info.hpp \
|
||||
vm/contexts.hpp \
|
||||
vm/run.hpp \
|
||||
vm/objects.hpp \
|
||||
vm/sampling_profiler.hpp \
|
||||
vm/errors.hpp \
|
||||
vm/bignumint.hpp \
|
||||
vm/bignum.hpp \
|
||||
vm/booleans.hpp \
|
||||
vm/instruction_operands.hpp \
|
||||
vm/code_blocks.hpp \
|
||||
vm/bump_allocator.hpp \
|
||||
vm/bitwise_hacks.hpp \
|
||||
vm/mark_bits.hpp \
|
||||
vm/free_list.hpp \
|
||||
vm/fixup.hpp \
|
||||
vm/write_barrier.hpp \
|
||||
vm/object_start_map.hpp \
|
||||
vm/aging_space.hpp \
|
||||
vm/tenured_space.hpp \
|
||||
vm/data_heap.hpp \
|
||||
vm/code_heap.hpp \
|
||||
vm/gc.hpp \
|
||||
vm/float_bits.hpp \
|
||||
vm/io.hpp \
|
||||
vm/image.hpp \
|
||||
vm/callbacks.hpp \
|
||||
vm/dispatch.hpp \
|
||||
vm/vm.hpp \
|
||||
vm/allot.hpp \
|
||||
vm/tagged.hpp \
|
||||
vm/data_roots.hpp \
|
||||
vm/code_roots.hpp \
|
||||
vm/generic_arrays.hpp \
|
||||
vm/callstack.hpp \
|
||||
vm/slot_visitor.hpp \
|
||||
vm/to_tenured_collector.hpp \
|
||||
vm/arrays.hpp \
|
||||
vm/math.hpp \
|
||||
vm/byte_arrays.hpp \
|
||||
vm/jit.hpp \
|
||||
vm/quotations.hpp \
|
||||
vm/inline_cache.hpp \
|
||||
vm/mvm.hpp \
|
||||
vm/factor.hpp \
|
||||
vm/utilities.hpp
|
||||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
|
||||
|
||||
TEST_OBJS = vm/ffi_test.o
|
||||
endif
|
||||
|
||||
default:
|
||||
$(MAKE) `./build.sh make-target`
|
||||
|
||||
help:
|
||||
@echo "Run '$(MAKE)' with one of the following parameters:"
|
||||
@echo ""
|
||||
@echo "linux-x86-32"
|
||||
@echo "linux-x86-64"
|
||||
@echo "linux-ppc-32"
|
||||
@echo "linux-ppc-64"
|
||||
@echo "linux-arm"
|
||||
@echo "freebsd-x86-32"
|
||||
@echo "freebsd-x86-64"
|
||||
@echo "macosx-x86-32"
|
||||
@echo "macosx-x86-64"
|
||||
@echo "macosx-x86-fat"
|
||||
@echo "windows-x86-32"
|
||||
@echo "windows-x86-64"
|
||||
@echo ""
|
||||
@echo "Additional modifiers:"
|
||||
@echo ""
|
||||
@echo "DEBUG=1 compile VM with debugging information"
|
||||
@echo "REPRODUCIBLE=1 compile VM without timestamp"
|
||||
@echo "SITE_CFLAGS=... additional optimization flags"
|
||||
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
|
||||
|
||||
ALL = factor factor-ffi-test factor-lib
|
||||
|
||||
freebsd-x86-32:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
|
||||
|
||||
freebsd-x86-64:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
|
||||
|
||||
macosx-x86-32:
|
||||
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
|
||||
|
||||
macosx-x86-64:
|
||||
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
|
||||
|
||||
macosx-x86-fat:
|
||||
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.fat
|
||||
|
||||
linux-x86-32:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
|
||||
|
||||
linux-x86-64:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
|
||||
|
||||
linux-ppc-32:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.32
|
||||
|
||||
linux-ppc-64:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.64
|
||||
|
||||
linux-arm:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
|
||||
|
||||
windows-x86-32:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.x86.32
|
||||
|
||||
windows-x86-64:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.x86.64
|
||||
|
||||
ifdef CONFIG
|
||||
|
||||
macosx.app: factor
|
||||
mkdir -p $(BUNDLE)/Contents/MacOS
|
||||
mkdir -p $(BUNDLE)/Contents/Frameworks
|
||||
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
ln -s Factor.app/Contents/MacOS/factor ./factor
|
||||
|
||||
$(ENGINE): $(DLL_OBJS)
|
||||
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
|
||||
factor-lib: $(ENGINE)
|
||||
|
||||
factor: $(EXE_OBJS) $(DLL_OBJS)
|
||||
$(TOOLCHAIN_PREFIX)$(CXX) -L. $(DLL_OBJS) \
|
||||
$(CFLAGS) $(CXXFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS)
|
||||
|
||||
factor-console: $(EXE_OBJS) $(DLL_OBJS)
|
||||
$(TOOLCHAIN_PREFIX)$(CXX) -L. $(DLL_OBJS) \
|
||||
$(CFLAGS) $(CXXFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS)
|
||||
|
||||
factor-ffi-test: $(FFI_TEST_LIBRARY)
|
||||
|
||||
$(FFI_TEST_LIBRARY): vm/ffi_test.o
|
||||
$(TOOLCHAIN_PREFIX)$(CC) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o $(FFI_TEST_LIBRARY) $(TEST_OBJS)
|
||||
|
||||
vm/resources.o:
|
||||
$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
||||
vm/ffi_test.o: vm/ffi_test.c
|
||||
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -std=c99 -o $@ $<
|
||||
|
||||
vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS)
|
||||
$(TOOLCHAIN_PREFIX)$(CXX) -c -x c++-header $(CFLAGS) $(CXXFLAGS) -o $@ $<
|
||||
|
||||
%.o: %.cpp vm/master.hpp.gch
|
||||
$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
|
||||
|
||||
%.o: %.S
|
||||
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
|
||||
|
||||
%.o: %.mm vm/master.hpp.gch
|
||||
$(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) $(CXXFLAGS) -o $@ $<
|
||||
|
||||
.SUFFIXES: .mm
|
||||
|
||||
endif
|
||||
|
||||
clean:
|
||||
rm -f vm/*.gch
|
||||
rm -f vm/*.o
|
||||
rm -f factor.dll
|
||||
rm -f factor.lib
|
||||
rm -f factor.dll.lib
|
||||
rm -f libfactor.*
|
||||
rm -f libfactor-ffi-test.*
|
||||
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
|
||||
|
||||
.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
Copyright (c) 2020, Slava Pestov, et al.
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
1. Redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer.
|
||||
2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
this list of conditions and the following disclaimer in the documentation
|
||||
and/or other materials provided with the distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
|
||||
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
||||
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
||||
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
100
Makefile
100
Makefile
|
|
@ -1,100 +0,0 @@
|
|||
CC = gcc
|
||||
DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
|
||||
#DEFAULT_CFLAGS = -g $(SITE_CFLAGS)
|
||||
DEFAULT_LIBS = -lm
|
||||
|
||||
STRIP = strip
|
||||
|
||||
UNIX_OBJS = native/unix/file.o native/unix/signal.o \
|
||||
native/unix/ffi.o native/unix/run.o
|
||||
|
||||
WIN32_OBJS = native/win32/ffi.o native/win32/file.o \
|
||||
native/win32/misc.o \
|
||||
native/win32/run.o
|
||||
|
||||
ifdef WIN32
|
||||
PLAF_OBJS = $(WIN32_OBJS)
|
||||
PLAF_SUFFIX = .exe
|
||||
else
|
||||
PLAF_OBJS = $(UNIX_OBJS)
|
||||
endif
|
||||
|
||||
OBJS = $(PLAF_OBJS) native/arithmetic.o native/array.o native/bignum.o \
|
||||
native/s48_bignum.o \
|
||||
native/complex.o native/cons.o native/error.o \
|
||||
native/factor.o native/fixnum.o \
|
||||
native/float.o native/gc.o \
|
||||
native/image.o native/memory.o \
|
||||
native/misc.o native/primitives.o \
|
||||
native/ratio.o native/relocate.o \
|
||||
native/run.o \
|
||||
native/sbuf.o native/stack.o \
|
||||
native/string.o native/types.o native/vector.o \
|
||||
native/word.o native/compiler.o \
|
||||
native/alien.o native/dll.o \
|
||||
native/boolean.o \
|
||||
native/debug.o \
|
||||
native/hashtable.o \
|
||||
native/icache.o \
|
||||
native/io.o
|
||||
|
||||
default:
|
||||
@echo "Run 'make' with one of the following parameters:"
|
||||
@echo ""
|
||||
@echo "bsd"
|
||||
@echo "bsd-nopthread - on FreeBSD 4, if you want to use profiling"
|
||||
@echo "linux"
|
||||
@echo "linux-ppc - to compile Factor on Linux/PowerPC"
|
||||
@echo "macosx"
|
||||
@echo ""
|
||||
@echo "Also, you might want to set the SITE_CFLAGS environment"
|
||||
@echo "variable to enable some CPU-specific optimizations; this"
|
||||
@echo "can make a huge difference. Eg:"
|
||||
@echo ""
|
||||
@echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\""
|
||||
|
||||
bsd:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -pthread" \
|
||||
LIBS="$(DEFAULT_LIBS)"
|
||||
$(STRIP) f
|
||||
|
||||
bsd-nopthread:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
|
||||
LIBS="$(DEFAULT_LIBS)"
|
||||
$(STRIP) f
|
||||
|
||||
macosx:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS)" \
|
||||
LIBS="$(DEFAULT_LIBS)"
|
||||
|
||||
linux:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
|
||||
LIBS="$(DEFAULT_LIBS) -ldl"
|
||||
$(STRIP) f
|
||||
|
||||
linux-ppc:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
|
||||
LIBS="$(DEFAULT_LIBS) -ldl"
|
||||
$(STRIP) f
|
||||
|
||||
windows:
|
||||
$(MAKE) f \
|
||||
CFLAGS="$(DEFAULT_CFLAGS) -DFFI -DWIN32" \
|
||||
LIBS="$(DEFAULT_LIBS)" WIN32=y
|
||||
|
||||
f: $(OBJS)
|
||||
$(CC) $(LIBS) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS)
|
||||
|
||||
clean:
|
||||
rm -f $(OBJS)
|
||||
|
||||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.S.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
|
@ -0,0 +1,205 @@
|
|||
VERSION = 0.99
|
||||
|
||||
# Crazy hack to do shell commands
|
||||
# We do it in Nmakefile because that way we don't have to invoke build through build.cmd
|
||||
# and we can just do ``nmake /f Nmakefile x86-64-vista`` or similar
|
||||
# and we still get the git branch, id, etc
|
||||
|
||||
!IF [git describe --all > git-describe.tmp] == 0
|
||||
GIT_DESCRIBE = \
|
||||
!INCLUDE <git-describe.tmp>
|
||||
!IF [del git-describe.tmp] == 0
|
||||
!ENDIF
|
||||
!ENDIF
|
||||
|
||||
!IF [git rev-parse HEAD > git-id.tmp] == 0
|
||||
GIT_ID = \
|
||||
!INCLUDE <git-id.tmp>
|
||||
!IF [del git-id.tmp] == 0
|
||||
!ENDIF
|
||||
!ENDIF
|
||||
|
||||
!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0
|
||||
GIT_BRANCH = \
|
||||
!INCLUDE <git-branch.tmp>
|
||||
!IF [del git-branch.tmp] == 0
|
||||
!ENDIF
|
||||
!ENDIF
|
||||
|
||||
GIT_LABEL = $(GIT_DESCRIBE)-$(GIT_ID)
|
||||
|
||||
!IF DEFINED(PLATFORM)
|
||||
|
||||
LINK_FLAGS = /nologo shell32.lib user32.lib
|
||||
CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS /DFACTOR_VERSION=$(VERSION) /DFACTOR_GIT_LABEL=$(GIT_LABEL)
|
||||
CL_FLAGS_VISTA = /D_WIN32_WINNT=0x0600
|
||||
|
||||
!IF "$(PLATFORM)" == "x86-32"
|
||||
LINK_FLAGS = $(LINK_FLAGS) /safeseh /largeaddressaware
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
|
||||
SUBSYSTEM_COM_FLAGS = console,"5.01"
|
||||
SUBSYSTEM_EXE_FLAGS = windows,"5.01"
|
||||
|
||||
!ELSEIF "$(PLATFORM)" == "x86-32-vista"
|
||||
LINK_FLAGS = $(LINK_FLAGS) /safeseh /largeaddressaware
|
||||
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj
|
||||
SUBSYSTEM_COM_FLAGS = console
|
||||
SUBSYSTEM_EXE_FLAGS = windows
|
||||
|
||||
!ELSEIF "$(PLATFORM)" == "x86-64"
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
|
||||
SUBSYSTEM_COM_FLAGS = console,"5.02"
|
||||
SUBSYSTEM_EXE_FLAGS = windows,"5.02"
|
||||
|
||||
|
||||
!ELSEIF "$(PLATFORM)" == "x86-64-vista"
|
||||
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
|
||||
SUBSYSTEM_COM_FLAGS = console
|
||||
SUBSYSTEM_EXE_FLAGS = windows
|
||||
|
||||
!ELSE
|
||||
CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA)
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj
|
||||
SUBSYSTEM_COM_FLAGS = console
|
||||
SUBSYSTEM_EXE_FLAGS = windows
|
||||
|
||||
!ENDIF
|
||||
|
||||
!IF DEFINED(DEBUG)
|
||||
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
|
||||
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
|
||||
!ENDIF
|
||||
|
||||
!IF DEFINED(REPRODUCIBLE)
|
||||
CL_FLAGS = $(CL_FLAGS) /DFACTOR_REPRODUCIBLE
|
||||
!ENDIF
|
||||
|
||||
ML_FLAGS = /nologo /safeseh
|
||||
|
||||
EXE_OBJS = vm\main-windows.obj vm\factor.res
|
||||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm\os-windows.obj \
|
||||
vm\aging_collector.obj \
|
||||
vm\alien.obj \
|
||||
vm\arrays.obj \
|
||||
vm\bignum.obj \
|
||||
vm\byte_arrays.obj \
|
||||
vm\callbacks.obj \
|
||||
vm\callstack.obj \
|
||||
vm\code_blocks.obj \
|
||||
vm\code_heap.obj \
|
||||
vm\compaction.obj \
|
||||
vm\contexts.obj \
|
||||
vm\data_heap.obj \
|
||||
vm\data_heap_checker.obj \
|
||||
vm\debug.obj \
|
||||
vm\dispatch.obj \
|
||||
vm\entry_points.obj \
|
||||
vm\errors.obj \
|
||||
vm\factor.obj \
|
||||
vm\full_collector.obj \
|
||||
vm\gc.obj \
|
||||
vm\image.obj \
|
||||
vm\inline_cache.obj \
|
||||
vm\instruction_operands.obj \
|
||||
vm\io.obj \
|
||||
vm\jit.obj \
|
||||
vm\math.obj \
|
||||
vm\mvm.obj \
|
||||
vm\mvm-windows.obj \
|
||||
vm\nursery_collector.obj \
|
||||
vm\object_start_map.obj \
|
||||
vm\objects.obj \
|
||||
vm\primitives.obj \
|
||||
vm\quotations.obj \
|
||||
vm\run.obj \
|
||||
vm\safepoints.obj \
|
||||
vm\sampling_profiler.obj \
|
||||
vm\strings.obj \
|
||||
vm\to_tenured_collector.obj \
|
||||
vm\tuples.obj \
|
||||
vm\utilities.obj \
|
||||
vm\vm.obj \
|
||||
vm\words.obj
|
||||
|
||||
# batch mode has ::
|
||||
.cpp.obj::
|
||||
cl /EHsc $(CL_FLAGS) /MP /Fovm/ /c $<
|
||||
|
||||
.c.obj::
|
||||
cl /EHsc $(CL_FLAGS) /MP /Fovm/ /c $<
|
||||
|
||||
.asm.obj:
|
||||
ml $(ML_FLAGS) /Fo$@ /c $<
|
||||
|
||||
.rs.res:
|
||||
rc $<
|
||||
|
||||
libfactor-ffi-test.dll: vm/ffi_test.obj
|
||||
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll /def:vm\ffi_test.def vm/ffi_test.obj
|
||||
|
||||
factor.dll.lib: $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
|
||||
|
||||
factor.com: $(EXE_OBJS) $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:$(SUBSYSTEM_COM_FLAGS) $(EXE_OBJS) $(DLL_OBJS)
|
||||
|
||||
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:$(SUBSYSTEM_EXE_FLAGS) $(EXE_OBJS) $(DLL_OBJS)
|
||||
|
||||
# If we compile factor.exe, run mt.exe, and run factor.exe,
|
||||
# then Windows caches the manifest. Even on a recompile without applying
|
||||
# the mt.exe tool, if the factor.exe.manifest file is present, the manifest
|
||||
# is applied. To avoid this, we delete the .manifest file on clean
|
||||
# and copy it from a reference file on compilation and mt.exe.
|
||||
#
|
||||
factor.exe.manifest: factor.exe
|
||||
copy factor.exe.manifest.in factor.exe.manifest
|
||||
mt -manifest factor.exe.manifest -outputresource:"factor.exe;#1"
|
||||
|
||||
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
|
||||
|
||||
!ENDIF
|
||||
|
||||
default:
|
||||
@echo Usage: nmake /f Nmakefile platform
|
||||
@echo Where platform is one of:
|
||||
@echo x86-32
|
||||
@echo x86-64
|
||||
@echo x86-32-vista
|
||||
@echo x86-64-vista
|
||||
@exit 1
|
||||
|
||||
x86-32:
|
||||
nmake /nologo PLATFORM=x86-32 /f Nmakefile all
|
||||
|
||||
x86-64:
|
||||
nmake /nologo PLATFORM=x86-64 /f Nmakefile all
|
||||
|
||||
x86-32-vista:
|
||||
nmake /nologo PLATFORM=x86-32-vista /f Nmakefile all
|
||||
|
||||
x86-64-vista:
|
||||
nmake /nologo PLATFORM=x86-64-vista /f Nmakefile all
|
||||
|
||||
clean:
|
||||
del vm\*.obj
|
||||
if exist vm\factor.res del vm\factor.res
|
||||
if exist factor.lib del factor.lib
|
||||
if exist factor.com del factor.com
|
||||
if exist factor.exe del factor.exe
|
||||
if exist factor.exe.manifest del factor.exe.manifest
|
||||
if exist factor.exp del factor.exp
|
||||
if exist factor.dll del factor.dll
|
||||
if exist factor.dll.lib del factor.dll.lib
|
||||
if exist factor.dll.exp del factor.dll.exp
|
||||
if exist libfactor-ffi-test.dll del libfactor-ffi-test.dll
|
||||
if exist libfactor-ffi-test.exp del libfactor-ffi-test.exp
|
||||
if exist libfactor-ffi-test.lib del libfactor-ffi-test.lib
|
||||
|
||||
.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean factor.exe.manifest
|
||||
|
||||
.SUFFIXES: .rs
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
# Factor
|
||||
|
||||
Factor is a [concatenative](https://www.concatenative.org), stack-based
|
||||
programming language with [high-level
|
||||
features](https://concatenative.org/wiki/view/Factor/Features/The%20language)
|
||||
including dynamic types, extensible syntax, macros, and garbage collection.
|
||||
On a practical side, Factor has a [full-featured
|
||||
library](https://docs.factorcode.org/content/article-vocab-index.html),
|
||||
supports many different platforms, and has been extensively documented.
|
||||
|
||||
The implementation is [fully
|
||||
compiled](https://concatenative.org/wiki/view/Factor/Optimizing%20compiler)
|
||||
for performance, while still supporting [interactive
|
||||
development](https://concatenative.org/wiki/view/Factor/Interactive%20development).
|
||||
Factor applications are portable between all common platforms. Factor can
|
||||
[deploy stand-alone
|
||||
applications](https://concatenative.org/wiki/view/Factor/Deployment) on all
|
||||
platforms. Full source code for the Factor project is available under a BSD
|
||||
license.
|
||||
|
||||
## Getting Started
|
||||
|
||||
### Building Factor from source
|
||||
|
||||
If you have a build environment set up, then you can build Factor from git.
|
||||
These scripts will attempt to compile the Factor binary and bootstrap from
|
||||
a boot image stored on factorcode.org.
|
||||
|
||||
To check out Factor:
|
||||
|
||||
* `git clone git://github.com/factor/factor.git`
|
||||
* `cd factor`
|
||||
|
||||
To build the latest complete Factor system from git, either use the
|
||||
build script:
|
||||
|
||||
* Unix: `./build.sh update`
|
||||
* Windows: `build.cmd`
|
||||
|
||||
or download the correct boot image for your system from
|
||||
http://downloads.factorcode.org/images/master/, put it in the `factor`
|
||||
directory and run:
|
||||
|
||||
* Unix: `make` and then `./factor -i=boot.unix-x86.64.image`
|
||||
* Windows: `nmake /f Nmakefile x86-64` and then `factor.com -i=boot.windows-x86.64.image`
|
||||
|
||||
Now you should have a complete Factor system ready to run.
|
||||
|
||||
More information on [building factor](https://concatenative.org/wiki/view/Factor/Building%20Factor)
|
||||
and [system requirements](https://concatenative.org/wiki/view/Factor/Requirements).
|
||||
|
||||
### To run a Factor binary:
|
||||
|
||||
You can download a Factor binary from the grid on [https://factorcode.org](https://factorcode.org).
|
||||
The nightly builds are usually a better experience than the point releases.
|
||||
|
||||
* Windows: Double-click `factor.exe`, or run `.\factor.com` in a command prompt
|
||||
* Mac OS X: Double-click `Factor.app` or run `open Factor.app` in a Terminal
|
||||
* Unix: Run `./factor` in a shell
|
||||
|
||||
### Learning Factor
|
||||
|
||||
A tutorial is available that can be accessed from the Factor environment:
|
||||
|
||||
```factor
|
||||
"first-program" help
|
||||
```
|
||||
|
||||
Some other simple things you can try in the listener:
|
||||
|
||||
```factor
|
||||
"Hello, world" print
|
||||
|
||||
{ 4 8 15 16 23 42 } [ 2 * ] map .
|
||||
|
||||
1000 [1,b] sum .
|
||||
|
||||
4 <iota> [
|
||||
"Happy Birthday " write
|
||||
2 = "dear NAME" "to You" ? print
|
||||
] each
|
||||
```
|
||||
|
||||
For more tips, see [Learning Factor](https://concatenative.org/wiki/view/Factor/Learning).
|
||||
|
||||
## Documentation
|
||||
|
||||
The Factor environment includes extensive reference documentation and a
|
||||
short "cookbook" to help you get started. The best way to read the
|
||||
documentation is in the UI; press F1 in the UI listener to open the help
|
||||
browser tool. You can also [browse the documentation
|
||||
online](https://docs.factorcode.org).
|
||||
|
||||
## Command Line Usage
|
||||
|
||||
Factor supports a number of command line switches:
|
||||
|
||||
```
|
||||
Usage: factor [Factor arguments] [script] [script arguments]
|
||||
|
||||
Common arguments:
|
||||
-help print this message and exit
|
||||
-i=<image> load Factor image file <image> (default factor.image)
|
||||
-run=<vocab> run the MAIN: entry point of <vocab>
|
||||
-run=listener run terminal listener
|
||||
-run=ui.tools run Factor development UI
|
||||
-e=<code> evaluate <code>
|
||||
-no-user-init suppress loading of .factor-rc
|
||||
-roots=<paths> a list of path-delimited extra vocab roots
|
||||
|
||||
Enter
|
||||
"command-line" help
|
||||
from within Factor for more information.
|
||||
```
|
||||
|
||||
You can also write scripts that can be run from the terminal, by putting
|
||||
``#!/path/to/factor`` at the top of your scripts and making them executable.
|
||||
|
||||
## Source Organization
|
||||
|
||||
The Factor source tree is organized as follows:
|
||||
|
||||
* `vm/` - Factor VM source code (not present in binary packages)
|
||||
* `core/` - Factor core library
|
||||
* `basis/` - Factor basis library, compiler, tools
|
||||
* `extra/` - more libraries and applications
|
||||
* `misc/` - editor modes, icons, etc
|
||||
* `unmaintained/` - now at [factor-unmaintained](https://github.com/factor/factor-unmaintained)
|
||||
|
||||
## Source History
|
||||
|
||||
During Factor's lifetime, sourcecode has lived in many repositories. Unfortunately, the first import in Git did not keep history. History has been partially recreated from what could be salvaged. Due to the nature of Git, it's only possible to add history without disturbing upstream work, by using replace objects. These need to be manually fetched, or need to be explicitly added to your git remote configuration.
|
||||
|
||||
Use:
|
||||
`git fetch origin 'refs/replace/*:refs/replace/*'`
|
||||
|
||||
or add the following line to your configuration file
|
||||
|
||||
```
|
||||
[remote "origin"]
|
||||
url = ...
|
||||
fetch = +refs/heads/*:refs/remotes/origin/*
|
||||
...
|
||||
fetch = +refs/replace/*:refs/replace/*
|
||||
```
|
||||
|
||||
Then subsequent fetches will automatically update any replace objects.
|
||||
|
||||
## Community
|
||||
|
||||
Factor developers meet in the `#concatenative` channel on
|
||||
[irc.freenode.net](http://freenode.net). Drop by if you want to discuss
|
||||
anything related to Factor or language design in general.
|
||||
|
||||
* [Factor homepage](https://factorcode.org)
|
||||
* [Concatenative languages wiki](https://concatenative.org)
|
||||
* [Mailing list](factor-talk@lists.sourceforge.net)
|
||||
* Search for "factorcode" on [Gitter](https://gitter.im/)
|
||||
|
||||
Have fun!
|
||||
263
README.txt
263
README.txt
|
|
@ -1,263 +0,0 @@
|
|||
THE CONCATENATIVE LANGUAGE FACTOR
|
||||
|
||||
* Introduction
|
||||
|
||||
Factor supports various data types; atomic types include numbers of
|
||||
various kinds, strings of characters, and booleans. Compound data types
|
||||
include lists consisting of cons cells, vectors, and string buffers.
|
||||
|
||||
Factor encourages programming in a functional style where new objects
|
||||
are returned and input parameters remain unmodified, but does not
|
||||
enforce this. No manifest type declarations are necessary, and all data
|
||||
types use exactly one slot each on the stack (unlike, say, FORTH).
|
||||
|
||||
The internal representation of a Factor program is a linked list. Linked
|
||||
lists that are to be executed are referred to as ``quotations.'' The
|
||||
interpreter iterates the list, executing words, and pushing all other
|
||||
types of objects on the data stack. A word is a unique data type because
|
||||
it can be executed. Words come in two varieties: primitive and compound.
|
||||
Primitive words have an implementation coded in the host language (C or
|
||||
Java). Compound words are executed by invoking the interpreter
|
||||
recursively on their definition, which is also a linked list.
|
||||
|
||||
* A note about code examples
|
||||
|
||||
Factor words are separated out into multiple ``vocabularies''. Each code
|
||||
example given here is preceeded with a series of declarations, such as
|
||||
the following:
|
||||
|
||||
USE: math
|
||||
USE: streams
|
||||
|
||||
When entering code at the interactive interpreter loop, most
|
||||
vocabularies are already in the search path, and the USE: declarations
|
||||
can be omitted. However, in a source file they must all be specified,
|
||||
by convention at the beginning of the file.
|
||||
|
||||
* Control flow
|
||||
|
||||
Control flow rests on two basic concepts: recursion, and branching.
|
||||
Words with compound definitions may refer to themselves, and there is
|
||||
exactly one primitive for performing conditional execution:
|
||||
|
||||
USE: combinators
|
||||
|
||||
1 10 < [ "1 is less than 10." print ] [ "whoa!" print ] ifte
|
||||
==> 1 is less than 10.
|
||||
|
||||
Here is an example of a word that uses these two concepts:
|
||||
|
||||
: contains? ( element list -- remainder )
|
||||
#! If the proper list contains the element, push the
|
||||
#! remainder of the list, starting from the cell whose car
|
||||
#! is elem. Otherwise push f.
|
||||
dup [
|
||||
2dup car = [ nip ] [ cdr contains? ] ifte
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
||||
An example:
|
||||
|
||||
USE: lists
|
||||
|
||||
3 [ 1 2 3 4 ] contains?
|
||||
==> [ 3 4 ]
|
||||
5 [ 1 2 3 4 ] contains?
|
||||
==> f
|
||||
|
||||
It recurses down the list, until it reaches the end, in which case the
|
||||
outer ifte's 'false' branch is executed.
|
||||
|
||||
A quick overview of the words used here, along with their stack effects:
|
||||
|
||||
Shuffle words:
|
||||
|
||||
dup ( x -- x x )
|
||||
nip ( x y -- y )
|
||||
2dup ( x y -- x y x y )
|
||||
2drop ( x y -- )
|
||||
|
||||
Linked list deconstruction:
|
||||
|
||||
car ( [ x | y ] -- x )
|
||||
cdr ( [ x | y ] -- y ) - push the "tail" of a list.
|
||||
|
||||
Equality:
|
||||
|
||||
= ( x y -- ? )
|
||||
|
||||
More complicated control flow constructs, such as loops and higher order
|
||||
functions, are usually built with the help of another primitive that
|
||||
simply executes a quotation at the top of the stack, removing it from
|
||||
the stack:
|
||||
|
||||
USE: math
|
||||
USE: prettyprint
|
||||
|
||||
[ 2 2 + . ] call
|
||||
==> 4
|
||||
|
||||
Here is an example of a word that applies a quotation to each element of
|
||||
a list. Note that it uses 'call' to execute the given quotation:
|
||||
|
||||
: each ( list quotation -- )
|
||||
#! Push each element of a proper list in turn, and apply a
|
||||
#! quotation to each element.
|
||||
over [
|
||||
>r uncons r> tuck >r >r call r> r> each
|
||||
] [
|
||||
2drop
|
||||
] ifte ;
|
||||
|
||||
An example:
|
||||
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: stack
|
||||
|
||||
[ 1 2 3 4 ] [ dup * . ] each
|
||||
==> 1
|
||||
4
|
||||
9
|
||||
16
|
||||
|
||||
A quick overview of the words used here:
|
||||
|
||||
Printing top of stack:
|
||||
|
||||
. ( x -- ) print top of stack in a form that is valid Factor syntax.
|
||||
|
||||
Shuffle words:
|
||||
|
||||
over ( x y -- x y x )
|
||||
tuck ( x y -- y x y )
|
||||
>r ( x -- r:x ) - move top of data stack to/from 'extra hand'.
|
||||
r> ( r:x -- x )
|
||||
|
||||
Writing >r foo r> is analogous to '[ foo ] dip' in Joy. Occurrences of
|
||||
>r and r> must be balanced within a single word definition.
|
||||
|
||||
Linked list deconstruction:
|
||||
|
||||
uncons ( [ x | y ] -- x y )
|
||||
|
||||
* Variables
|
||||
|
||||
Factor supports a notion of ``variables''. Whereas the stack is used for
|
||||
transient, intermediate values, variables are used for more permanent
|
||||
data.
|
||||
|
||||
Variables are retreived and stored using the 'get' and 'set' words. For
|
||||
example:
|
||||
|
||||
USE: math
|
||||
USE: namespaces
|
||||
USE: prettyprint
|
||||
|
||||
"~" get .
|
||||
==> "/home/slava"
|
||||
|
||||
5 "x" set
|
||||
"x" get 2 * .
|
||||
==> 10
|
||||
|
||||
The set of available variables is determined using ``dynamic scope''.
|
||||
A ``namespace'' is a set of variable name/value pairs. Namespaces can be
|
||||
pushed onto the ``name stack'', and later popped. The 'get' word
|
||||
searches all namespaces on the namestack in turn. The 'set' word stores
|
||||
a variable value into the namespace at the top of the name stack.
|
||||
|
||||
While it is possible to push/pop the namestack directly using the words
|
||||
>n and n>, most of the time using the 'bind' combinator is more
|
||||
desirable.
|
||||
|
||||
Good examples of namespace use are found in the I/O system.
|
||||
|
||||
Factor provides two sets of words for working with I/O streams: words
|
||||
whose stream operand is specified on the stack (freadln, fwrite,
|
||||
fprint...) and words that use the standard input/output stream (read,
|
||||
write, print...).
|
||||
|
||||
An I/O stream is a namespace with a slot for each I/O operation. I/O
|
||||
operations taking an explicit stream operand are all defined as follows:
|
||||
|
||||
: freadln ( stream -- string )
|
||||
[ "freadln" get call ] bind ;
|
||||
|
||||
: fwrite ( string stream -- )
|
||||
[ "fwrite" get call ] bind ;
|
||||
|
||||
: fclose ( stream -- )
|
||||
[ "fclose" get call ] bind ;
|
||||
|
||||
( ... et cetera )
|
||||
|
||||
The second set of I/O operations, whose stream is the implicit 'standard
|
||||
input/output' stream, are defined as follows:
|
||||
|
||||
: read ( -- string )
|
||||
"stdio" get freadln ;
|
||||
|
||||
: write ( string -- )
|
||||
"stdio" get fwrite ;
|
||||
|
||||
( ... et cetera )
|
||||
|
||||
In the global namespace, the 'stdio' variable corresponds to a stream
|
||||
whose operations read/write from the standard file descriptors 0 and 1.
|
||||
|
||||
However, the 'with-stream' combinator provides a way to rebind the
|
||||
standard input/output stream for the duration of the execution of a
|
||||
single quotation. The following example writes the source of a word
|
||||
definition to a file named 'definition.txt':
|
||||
|
||||
USE: prettyprint
|
||||
USE: streams
|
||||
|
||||
"definition.txt" <filebw> [ "with-stream" see ] with-stream
|
||||
|
||||
The 'with-stream' word is implemented by pushing a new namespace on the
|
||||
namestack, setting the 'stdio' variable therein, and execution the given
|
||||
quotation.
|
||||
|
||||
* Continuations
|
||||
|
||||
A continuation is a quotation that restores execution to the point where
|
||||
it was captured. Continuations are captured using the callcc0 and
|
||||
callcc1 words in the 'continuations' vocabulary.
|
||||
|
||||
The word names are abbreviations for 'call with current continuation';
|
||||
the 0 or 1 refers to the arity of the continuation.
|
||||
|
||||
Consider the phrase 'call with current continuation':
|
||||
|
||||
- 'call' -- it calls a quotation given as a parameter...
|
||||
- 'with' -- with a value on the stack....
|
||||
- 'current continuation' -- that is a quotation that can be called
|
||||
to restore execution at the current point.
|
||||
|
||||
A continuation can either have arity 0 or 1. This refers to the number
|
||||
of parameters the quotation transfers from the caller stack to the
|
||||
restored point.
|
||||
|
||||
Three very simple examples:
|
||||
|
||||
[ call ] callcc0 "Hello world." print
|
||||
^
|
||||
------- captured continuation restores here.
|
||||
==> Hello world.
|
||||
|
||||
[ "my-c" set ] callcc0 "Hello world." print
|
||||
^
|
||||
-------- captured continuation restores here.
|
||||
==> Hello world.
|
||||
|
||||
"my-c" get call
|
||||
==> Hello world.
|
||||
|
||||
Continuations are an advanced feature and are used in the implementation
|
||||
of error handling, multi-tasking, co-routines, and generators.
|
||||
|
||||
(This is for my editor. It can be removed.
|
||||
:tabSize=4:indentSize=4:noTabs=true:)
|
||||
125
TODO.FACTOR.txt
125
TODO.FACTOR.txt
|
|
@ -1,125 +0,0 @@
|
|||
+ plugin:
|
||||
|
||||
- if external factor is down, don't add tons of random shit to the
|
||||
dictionary
|
||||
- word preview for parsing words
|
||||
|
||||
+ ui:
|
||||
|
||||
- faster layout
|
||||
- faster repaint
|
||||
- console with presentations
|
||||
- ui browser
|
||||
- auto-updating inspector, mirrors abstraction
|
||||
- mouse enter onto overlapping with interior, but not child, gadget
|
||||
- menu dragging
|
||||
- fix up the min thumb size hack
|
||||
- frame gap
|
||||
- tiled window manager
|
||||
- rotating cube demo
|
||||
|
||||
+ ffi:
|
||||
|
||||
- clarify powerpc passing of value struct parameters
|
||||
- char* struct members
|
||||
- box/unbox_signed/unsigned_8
|
||||
- ffi unicode strings: null char security hole
|
||||
- utf16 string boxing
|
||||
- value type structs
|
||||
- out parameter cleanup
|
||||
- bitfields in C structs
|
||||
- SDL_Rect** type
|
||||
- setting struct members that are not *
|
||||
- char[14], etc members -- generalize char255
|
||||
- FFI float types
|
||||
|
||||
+ compiler:
|
||||
|
||||
- get all-tests to run with -no-compile
|
||||
- fix i/o on generic x86/ppc unix
|
||||
- alien primitives need a more general input type
|
||||
- [ [ dup call ] dup call ] infer hangs
|
||||
- more accurate types for various words
|
||||
- declarations
|
||||
- type inference fails with some assembler words;
|
||||
displaced, register and other predicates need to inherit from list
|
||||
not cons, and need stronger branch partial eval
|
||||
- redo partial eval
|
||||
- optimize away arithmetic dispatch
|
||||
- dataflow optimizer needs eq not =
|
||||
- the invalid recursion form case needs to be fixed, for inlines too
|
||||
- #jump-f #jump-f-label
|
||||
- re-introduce #target-label => #target optimization
|
||||
|
||||
+ sequences
|
||||
|
||||
- 2map, sequence= slow with lists
|
||||
- nappend: instead of using push, enlarge the sequence with set-length
|
||||
then add set the elements with set-nth
|
||||
- ensure-capacity: don't be generic
|
||||
- vector's ensure-capacity will crash if not given fixnums!
|
||||
- dipping seq-2nmap, seq-2each
|
||||
- generic each some? all? member? memq? all=? index? subseq? map
|
||||
- index and index* are very slow with lists
|
||||
- list map, subset: not tail recursive
|
||||
- phase out sbuf-append, index-of, substring
|
||||
- unsafe-sbuf>string
|
||||
- generic subseq
|
||||
- GENERIC: map
|
||||
- list impl same as now
|
||||
- generic parser::scan
|
||||
- array sort
|
||||
|
||||
+ kernel:
|
||||
|
||||
- powerpc has weird callstack residue
|
||||
- .factor-rc loading errors are not reported properly
|
||||
- instances: do not use make-list
|
||||
- unions containing tuples do not work properly
|
||||
- need G: combinations
|
||||
- method doc strings
|
||||
- code walker & exceptions
|
||||
- string sub-primitives
|
||||
- clean up metaclasses
|
||||
- vectors: ensure its ok with bignum indices
|
||||
- code gc
|
||||
- generational gc
|
||||
- doc comments of generics
|
||||
- M: object should not inhibit delegation
|
||||
- renumber types appopriately
|
||||
|
||||
+ i/o:
|
||||
|
||||
- faster stream-copy
|
||||
- rename prettyprint to pprint
|
||||
- reading and writing byte arrays
|
||||
- merge unix and win32 io where appropriate
|
||||
- unix io: handle \n\r and \n\0
|
||||
- reader syntax for arrays, byte arrays, displaced aliens
|
||||
- separate words for writing characters and strings
|
||||
- perhaps:
|
||||
GENERIC: set-style ( style stream -- )
|
||||
GENERIC: stream-write
|
||||
GENERIC: stream-write-char
|
||||
- stream server can hang because of exception handler limitations
|
||||
- better i/o scheduler
|
||||
- add a socket timeout
|
||||
- unify unparse and prettyprint
|
||||
- utf16, utf8 encoding
|
||||
|
||||
+ nice to have libraries:
|
||||
|
||||
- make-matrix is slow and ugly
|
||||
- move 2repeat somewhere else
|
||||
- regexps
|
||||
- XML
|
||||
- real Unicode support (strings are already 16 bits and can be extended
|
||||
to 21 if the need arises, but we need full character classification
|
||||
predicates, comparison, case conversion, sorting...)
|
||||
- full Win32 binding
|
||||
- Cairo binding
|
||||
|
||||
+ http:
|
||||
|
||||
- virtual hosts
|
||||
- keep alive
|
||||
105
actions.xml
105
actions.xml
|
|
@ -1,105 +0,0 @@
|
|||
<?xml version="1.0"?>
|
||||
|
||||
<!DOCTYPE ACTIONS SYSTEM "actions.dtd">
|
||||
|
||||
<ACTIONS>
|
||||
<ACTION NAME="factor-listener">
|
||||
<CODE>
|
||||
wm.addDockableWindow("console");
|
||||
wm.getDockableWindow("console").setShell("Factor");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-restart">
|
||||
<CODE>
|
||||
FactorPlugin.restartExternalInstance();
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-eval-selection">
|
||||
<CODE>
|
||||
sel = textArea.selectedText;
|
||||
if(sel == null)
|
||||
view.toolkit.beep();
|
||||
else
|
||||
FactorPlugin.evalInListener(view,sel);
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-run-file">
|
||||
<CODE>
|
||||
buffer.save(view,null);
|
||||
VFSManager.waitForRequests();
|
||||
FactorPlugin.evalInListener(view,
|
||||
"\""
|
||||
+ FactorReader.charsToEscapes(buffer.path)
|
||||
+ "\" run-file");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-apropos">
|
||||
<CODE>
|
||||
word = FactorPlugin.getWordAtCaret(textArea);
|
||||
if(word == null)
|
||||
view.toolkit.beep();
|
||||
else
|
||||
{
|
||||
FactorPlugin.evalInListener(view,
|
||||
"\""
|
||||
+ FactorReader.charsToEscapes(word)
|
||||
+ "\" apropos.");
|
||||
}
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-see">
|
||||
<CODE>
|
||||
FactorPlugin.factorWordPopupOp(view,"see");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-edit">
|
||||
<CODE>
|
||||
FactorPlugin.factorWordWireOp(view,"jedit");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-edit-dialog">
|
||||
<CODE>
|
||||
new EditWordDialog(view,FactorPlugin
|
||||
.getSideKickParser());
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-usages">
|
||||
<CODE>
|
||||
FactorPlugin.factorWordOutputOp(view,"usages .");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-insert-use">
|
||||
<CODE>
|
||||
word = FactorPlugin.getWordAtCaret(textArea);
|
||||
if(word == null)
|
||||
view.toolkit.beep();
|
||||
else
|
||||
FactorPlugin.insertUseDialog(view,word);
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-extract-word">
|
||||
<CODE>
|
||||
FactorPlugin.extractWord(view);
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-infer-effect">
|
||||
<CODE>
|
||||
FactorPlugin.factorWordPopupOp(view,"unit infer .");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-compile">
|
||||
<CODE>
|
||||
FactorPlugin.factorWordOutputOp(view,"recompile");
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-infer-effects">
|
||||
<CODE>
|
||||
InferBufferProcessor.createInferUnitTests(view,buffer);
|
||||
</CODE>
|
||||
</ACTION>
|
||||
<ACTION NAME="factor-compile-all">
|
||||
<CODE>
|
||||
new CompileBufferProcessor(view,buffer);
|
||||
</CODE>
|
||||
</ACTION>
|
||||
</ACTIONS>
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.accessors alien.c-types alien.strings
|
||||
arrays compiler.units cpu.architecture fry io.encodings.binary
|
||||
io.encodings.utf8 kernel math sequences words ;
|
||||
IN: alien.arrays
|
||||
|
||||
INSTANCE: array value-type
|
||||
|
||||
M: array lookup-c-type ;
|
||||
|
||||
M: array c-type-class drop object ;
|
||||
|
||||
M: array c-type-boxed-class drop object ;
|
||||
|
||||
: array-length ( seq -- n )
|
||||
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
|
||||
|
||||
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
||||
M: array c-type-align-first first c-type-align-first ;
|
||||
|
||||
M: array base-type drop void* base-type ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ c-string = ] [ word? ] bi* and ;
|
||||
|
||||
M: string-type lookup-c-type ;
|
||||
|
||||
M: string-type c-type-class drop object ;
|
||||
|
||||
M: string-type c-type-boxed-class drop object ;
|
||||
|
||||
M: string-type heap-size drop void* heap-size ;
|
||||
|
||||
M: string-type c-type-align drop void* c-type-align ;
|
||||
|
||||
M: string-type c-type-align-first drop void* c-type-align-first ;
|
||||
|
||||
M: string-type base-type drop void* base-type ;
|
||||
|
||||
M: string-type c-type-rep drop int-rep ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second dup binary =
|
||||
[ drop void* c-type-boxer-quot ]
|
||||
[ '[ _ alien>string ] ] if ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second dup binary =
|
||||
[ drop void* c-type-unboxer-quot ]
|
||||
[ '[ _ string>alien ] ] if ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
||||
M: string-type c-type-copier
|
||||
drop [ ] ;
|
||||
|
||||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
[ { c-string utf8 } c-string typedef ] with-compilation-unit
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
C array support
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,184 @@
|
|||
USING: alien help.syntax help.markup libc kernel.private
|
||||
byte-arrays strings hashtables alien.syntax alien.strings
|
||||
sequences io.encodings.string debugger destructors vocabs.loader
|
||||
classes.struct math kernel ;
|
||||
IN: alien.c-types
|
||||
|
||||
HELP: heap-size
|
||||
{ $values { "name" c-type-name } { "size" math:integer } }
|
||||
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
||||
{ $examples
|
||||
{ $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
|
||||
}
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: <c-type>
|
||||
{ $values { "c-type" c-type } }
|
||||
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
|
||||
|
||||
HELP: no-c-type
|
||||
{ $values { "name" c-type-name } }
|
||||
{ $description "Throws a " { $link no-c-type } " error." }
|
||||
{ $error-description "Thrown by " { $link c-type } " if a given word is not a C type." } ;
|
||||
|
||||
HELP: lookup-c-type
|
||||
{ $values { "name" c-type-name } { "c-type" c-type } }
|
||||
{ $description "Looks up a C type by name." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
|
||||
|
||||
HELP: alien-value
|
||||
{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
|
||||
{ $description "Loads a value at a byte offset from a base C pointer." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: set-alien-value
|
||||
{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
|
||||
{ $description "Stores a value at a byte offset from a base C pointer." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: char
|
||||
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||
HELP: uchar
|
||||
{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||
HELP: short
|
||||
{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||
HELP: ushort
|
||||
{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||
HELP: int
|
||||
{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: uint
|
||||
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: long
|
||||
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: intptr_t
|
||||
{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ulong
|
||||
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: uintptr_t
|
||||
{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ptrdiff_t
|
||||
{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: size_t
|
||||
{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: longlong
|
||||
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: ulonglong
|
||||
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
|
||||
HELP: void
|
||||
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
|
||||
HELP: void*
|
||||
{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
|
||||
HELP: c-string
|
||||
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
|
||||
HELP: float
|
||||
{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
|
||||
HELP: double
|
||||
{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
|
||||
|
||||
HELP: pointer:
|
||||
{ $syntax "pointer: c-type" }
|
||||
{ $description "Constructs a " { $link pointer } " C type." } ;
|
||||
|
||||
HELP: pointer
|
||||
{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to. Both " { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
|
||||
$nl
|
||||
"Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null."
|
||||
$nl
|
||||
"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
|
||||
{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
|
||||
{ $unchecked-example ": foo ( bar -- int* )
|
||||
pointer: int f \"foo\" { pointer: char } f alien-invoke ;" } } ;
|
||||
|
||||
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||
$nl
|
||||
"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
|
||||
{ $list
|
||||
"the C function returns"
|
||||
"the C function calls Factor code via a callback"
|
||||
}
|
||||
"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
|
||||
$nl
|
||||
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
|
||||
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
|
||||
|
||||
ARTICLE: "c-types.primitives" "Primitive C types"
|
||||
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||
{ $table
|
||||
{ { $strong "C type" } { $strong "Notes" } }
|
||||
{ { $link char } "always 1 byte" }
|
||||
{ { $link uchar } { } }
|
||||
{ { $link short } "always 2 bytes" }
|
||||
{ { $link ushort } { } }
|
||||
{ { $link int } "always 4 bytes" }
|
||||
{ { $link uint } { } }
|
||||
{ { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
|
||||
{ { $link ulong } { } }
|
||||
{ { $link longlong } "always 8 bytes" }
|
||||
{ { $link ulonglong } { } }
|
||||
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
|
||||
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
|
||||
}
|
||||
"C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary."
|
||||
$nl
|
||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
|
||||
|
||||
ARTICLE: "c-types.pointers" "Pointer and array types"
|
||||
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. This syntax constructs a " { $link pointer } " object to represent the C type."
|
||||
$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 with the dimensions only serving as documentation." ;
|
||||
|
||||
ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
|
||||
"Note that some of the C type word names clash with commonly-used Factor words:"
|
||||
{ $list
|
||||
{ { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
|
||||
{ { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
|
||||
}
|
||||
"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
|
||||
{ $code
|
||||
"USING: alien.syntax math prettyprint ;"
|
||||
"FUNCTION: float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
|
||||
{ $code
|
||||
"USING: alien.c-types alien.syntax math prettyprint ;"
|
||||
"FUNCTION: float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
|
||||
{ $code
|
||||
"USING: alien.syntax math prettyprint ;"
|
||||
"QUALIFIED-WITH: alien.c-types c"
|
||||
"FUNCTION: c:float magic_number ( ) ;"
|
||||
"magic_number 3.0 + ."
|
||||
}
|
||||
"See " { $link "word-search-semantics" } " for details." ;
|
||||
|
||||
ARTICLE: "c-types.structs" "Struct and union types"
|
||||
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
|
||||
|
||||
ARTICLE: "c-types-specs" "C type specifiers"
|
||||
"C types are identified by special words. Type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
|
||||
$nl
|
||||
"Defining new C types:"
|
||||
{ $subsections
|
||||
POSTPONE: STRUCT:
|
||||
POSTPONE: UNION-STRUCT:
|
||||
POSTPONE: CALLBACK:
|
||||
POSTPONE: TYPEDEF:
|
||||
}
|
||||
"Getting the c-type of a class:"
|
||||
{ $subsections lookup-c-type }
|
||||
{ $heading "Related articles" }
|
||||
{ $subsections
|
||||
"c-types.primitives"
|
||||
"c-types.pointers"
|
||||
"c-types.ambiguity"
|
||||
"c-types.structs"
|
||||
}
|
||||
;
|
||||
|
||||
ABOUT: "c-types-specs"
|
||||
|
|
@ -0,0 +1,168 @@
|
|||
USING: accessors alien.c-types alien.syntax classes
|
||||
classes.struct compiler.units eval io.encodings.ascii kernel
|
||||
math.constants tools.test ;
|
||||
FROM: alien.c-types => short ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
{ 492 } [ { int xyz } heap-size ] unit-test
|
||||
|
||||
UNION-STRUCT: foo
|
||||
{ a int }
|
||||
{ b int } ;
|
||||
|
||||
{ t } [ pointer: void lookup-c-type void* lookup-c-type = ] unit-test
|
||||
{ t } [ pointer: int lookup-c-type void* lookup-c-type = ] unit-test
|
||||
{ t } [ pointer: int* lookup-c-type void* lookup-c-type = ] unit-test
|
||||
{ f } [ pointer: foo lookup-c-type void* lookup-c-type = ] unit-test
|
||||
{ t } [ pointer: foo* lookup-c-type void* lookup-c-type = ] unit-test
|
||||
|
||||
{ t } [ c-string lookup-c-type c-string lookup-c-type = ] unit-test
|
||||
|
||||
{ t } [ foo heap-size int heap-size = ] unit-test
|
||||
|
||||
TYPEDEF: int MyInt
|
||||
|
||||
{ t } [ int lookup-c-type MyInt lookup-c-type = ] unit-test
|
||||
{ t } [ void* lookup-c-type pointer: MyInt lookup-c-type = ] unit-test
|
||||
|
||||
{ 32 } [ { int 8 } heap-size ] unit-test
|
||||
|
||||
{ } [ pointer: { int 8 } heap-size pointer: void heap-size assert= ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
{ t } [ pointer: void lookup-c-type pointer: MyChar lookup-c-type = ] unit-test
|
||||
|
||||
TYPEDEF: { c-string ascii } MyFunkyString
|
||||
|
||||
{ { c-string ascii } } [ MyFunkyString lookup-c-type ] unit-test
|
||||
|
||||
TYPEDEF: c-string MyString
|
||||
|
||||
{ t } [ c-string lookup-c-type MyString lookup-c-type = ] unit-test
|
||||
{ t } [ void* lookup-c-type pointer: MyString lookup-c-type = ] unit-test
|
||||
|
||||
TYPEDEF: int* MyIntArray
|
||||
|
||||
{ t } [ void* lookup-c-type MyIntArray lookup-c-type = ] unit-test
|
||||
|
||||
{ 0 } [ -10 uchar c-type-clamp ] unit-test
|
||||
{ 12 } [ 12 uchar c-type-clamp ] unit-test
|
||||
{ -10 } [ -10 char c-type-clamp ] unit-test
|
||||
{ 127 } [ 230 char c-type-clamp ] unit-test
|
||||
{ t } [ pi dup float c-type-clamp = ] unit-test
|
||||
|
||||
C-TYPE: opaque
|
||||
|
||||
{ t } [ void* lookup-c-type pointer: opaque lookup-c-type = ] unit-test
|
||||
[ opaque lookup-c-type ] [ no-c-type? ] must-fail-with
|
||||
|
||||
! c-type-string
|
||||
{
|
||||
"c-string[ascii]"
|
||||
"foo*"
|
||||
"int[5]"
|
||||
"int**"
|
||||
"MyFunkyString*"
|
||||
"opaque*"
|
||||
} [
|
||||
{ c-string ascii } c-type-string
|
||||
pointer: foo c-type-string
|
||||
{ int 5 } c-type-string
|
||||
pointer: pointer: int c-type-string
|
||||
pointer: MyFunkyString c-type-string
|
||||
pointer: opaque c-type-string
|
||||
] unit-test
|
||||
|
||||
[ "
|
||||
USING: alien.syntax ;
|
||||
IN: alien.c-types.tests
|
||||
FUNCTION: opaque return_opaque ( ) ;
|
||||
" eval( -- ) ] [ no-c-type? ] must-fail-with
|
||||
|
||||
C-TYPE: forward
|
||||
STRUCT: backward { x forward* } ;
|
||||
STRUCT: forward { x backward* } ;
|
||||
|
||||
{ t } [ forward lookup-c-type struct-c-type? ] unit-test
|
||||
{ t } [ backward lookup-c-type struct-c-type? ] unit-test
|
||||
|
||||
DEFER: struct-redefined
|
||||
|
||||
{ f }
|
||||
[
|
||||
|
||||
"
|
||||
USING: alien.c-types classes.struct ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
STRUCT: struct-redefined { x int } ;
|
||||
" eval( -- )
|
||||
|
||||
"
|
||||
USING: alien.syntax ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
C-TYPE: struct-redefined
|
||||
" eval( -- )
|
||||
|
||||
\ struct-redefined class?
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
TYPEDEF: int type-redefinition-test
|
||||
TYPEDEF: int type-redefinition-test" eval( -- )
|
||||
]
|
||||
[ error>> error>> redefine-error? ]
|
||||
must-fail-with
|
||||
|
||||
[
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
CALLBACK: void cb987 ( )
|
||||
CALLBACK: void cb987 ( )" eval( -- )
|
||||
]
|
||||
[ error>> error>> redefine-error? ]
|
||||
must-fail-with
|
||||
|
||||
[
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
FUNCTION: void func987 ( )
|
||||
FUNCTION: void func987 ( )" eval( -- )
|
||||
]
|
||||
[ error>> error>> redefine-error? ]
|
||||
must-fail-with
|
||||
|
||||
! generic -> callback
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
GENERIC: foo-func ( x -- )
|
||||
" eval( -- )
|
||||
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
CALLBACK: void foo-func ( )
|
||||
" eval( -- )
|
||||
|
||||
! generic -> typedef
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
GENERIC: foo-func ( x -- )
|
||||
" eval( -- )
|
||||
|
||||
"IN: alien.c-types.tests
|
||||
USE: alien.syntax
|
||||
USE: alien.c-types
|
||||
TYPEDEF: void* foo-func
|
||||
" eval( -- )
|
||||
|
|
@ -0,0 +1,518 @@
|
|||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays classes combinators
|
||||
compiler.units cpu.architecture delegate fry kernel layouts macros
|
||||
math math.order math.parser quotations sequences summary system words
|
||||
words.symbol ;
|
||||
IN: alien.c-types
|
||||
|
||||
SYMBOLS:
|
||||
char uchar
|
||||
short ushort
|
||||
int uint
|
||||
long ulong
|
||||
longlong ulonglong
|
||||
float double
|
||||
void* bool ;
|
||||
|
||||
SINGLETON: void
|
||||
|
||||
TUPLE: abstract-c-type
|
||||
{ class class initial: object }
|
||||
{ boxed-class class initial: object }
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ size integer }
|
||||
{ signed boolean }
|
||||
{ align integer }
|
||||
{ align-first integer } ;
|
||||
|
||||
TUPLE: c-type < abstract-c-type
|
||||
boxer
|
||||
unboxer
|
||||
{ rep initial: int-rep } ;
|
||||
|
||||
: <c-type> ( -- c-type )
|
||||
\ c-type new ; inline
|
||||
|
||||
ERROR: no-c-type word ;
|
||||
|
||||
M: no-c-type summary drop "Not a C type" ;
|
||||
|
||||
! C type protocol
|
||||
GENERIC: lookup-c-type ( name -- c-type ) foldable
|
||||
|
||||
PREDICATE: c-type-word < word
|
||||
"c-type" word-prop >boolean ;
|
||||
|
||||
TUPLE: pointer { to initial: void read-only } ;
|
||||
C: <pointer> pointer
|
||||
|
||||
UNION: c-type-name
|
||||
c-type-word pointer ;
|
||||
|
||||
: resolve-typedef ( name -- c-type )
|
||||
dup void? [ no-c-type ] when
|
||||
dup c-type-name? [ lookup-c-type ] when ;
|
||||
|
||||
M: word lookup-c-type
|
||||
dup "c-type" word-prop resolve-typedef
|
||||
[ ] [ no-c-type ] ?if ;
|
||||
|
||||
GENERIC: c-type-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
||||
GENERIC: c-type-boxed-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-boxed-class boxed-class>> ;
|
||||
|
||||
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
GENERIC: c-type-rep ( name -- rep )
|
||||
|
||||
M: c-type c-type-rep rep>> ;
|
||||
|
||||
GENERIC: c-type-getter ( name -- quot )
|
||||
|
||||
M: c-type c-type-getter getter>> ;
|
||||
|
||||
GENERIC: c-type-copier ( name -- quot )
|
||||
|
||||
M: c-type c-type-copier drop [ ] ;
|
||||
|
||||
GENERIC: c-type-setter ( name -- quot )
|
||||
|
||||
M: c-type c-type-setter setter>> ;
|
||||
|
||||
GENERIC: c-type-signed ( name -- boolean ) foldable
|
||||
|
||||
M: abstract-c-type c-type-signed signed>> ;
|
||||
|
||||
GENERIC: c-type-align ( name -- n ) foldable
|
||||
|
||||
M: abstract-c-type c-type-align align>> ;
|
||||
|
||||
GENERIC: c-type-align-first ( name -- n )
|
||||
|
||||
M: abstract-c-type c-type-align-first align-first>> ;
|
||||
|
||||
GENERIC: base-type ( c-type -- c-type )
|
||||
|
||||
M: c-type-name base-type lookup-c-type ;
|
||||
|
||||
M: c-type base-type ;
|
||||
|
||||
GENERIC: heap-size ( name -- size )
|
||||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
MIXIN: value-type
|
||||
|
||||
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
|
||||
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
|
||||
|
||||
MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
|
||||
[ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
|
||||
|
||||
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
|
||||
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
|
||||
[ c-type-setter ]
|
||||
bi append ;
|
||||
|
||||
: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
|
||||
[ swapd heap-size * >fixnum ] keep ; inline
|
||||
|
||||
: alien-element ( n c-ptr c-type -- value )
|
||||
array-accessor alien-value ; inline
|
||||
|
||||
: set-alien-element ( value n c-ptr c-type -- )
|
||||
array-accessor set-alien-value ; inline
|
||||
|
||||
PROTOCOL: c-type-protocol
|
||||
c-type-class
|
||||
c-type-boxed-class
|
||||
c-type-boxer-quot
|
||||
c-type-unboxer-quot
|
||||
c-type-rep
|
||||
c-type-getter
|
||||
c-type-copier
|
||||
c-type-setter
|
||||
c-type-signed
|
||||
c-type-align
|
||||
c-type-align-first
|
||||
base-type
|
||||
heap-size ;
|
||||
|
||||
CONSULT: c-type-protocol c-type-name
|
||||
lookup-c-type ;
|
||||
|
||||
PREDICATE: typedef-word < c-type-word
|
||||
"c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
|
||||
|
||||
: typedef ( old new -- )
|
||||
{
|
||||
[ nip define-symbol ]
|
||||
[ swap "c-type" set-word-prop ]
|
||||
} 2cleave ;
|
||||
|
||||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- c-type )
|
||||
long-long-type new ;
|
||||
|
||||
: if-void ( ..a c-type true: ( ..a -- ..b ) false: ( ..a c-type -- ..b ) -- ..b )
|
||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
SYMBOLS:
|
||||
ptrdiff_t intptr_t uintptr_t size_t
|
||||
c-string int8_t uint8_t int16_t uint16_t
|
||||
int32_t uint32_t int64_t uint64_t ;
|
||||
|
||||
CONSTANT: primitive-types
|
||||
{
|
||||
char uchar
|
||||
short ushort
|
||||
int uint
|
||||
long ulong
|
||||
longlong ulonglong
|
||||
float double
|
||||
void* bool
|
||||
c-string
|
||||
}
|
||||
|
||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||
|
||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 8-byte-alignment ( c-type -- c-type )
|
||||
{
|
||||
{ [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
|
||||
[ 8 >>align 8 >>align-first ]
|
||||
} cond ;
|
||||
|
||||
: resolve-pointer-typedef ( type -- base-type )
|
||||
dup "c-type" word-prop dup word?
|
||||
[ nip resolve-pointer-typedef ] [
|
||||
pointer? [ drop void* ] when
|
||||
] if ;
|
||||
|
||||
: primitive-pointer-type? ( type -- ? )
|
||||
dup c-type-word? [
|
||||
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
|
||||
] [ drop t ] if ;
|
||||
|
||||
: (pointer-c-type) ( void* type -- void*' )
|
||||
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: pointer lookup-c-type
|
||||
[ \ void* lookup-c-type ] dip
|
||||
to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
|
||||
|
||||
[
|
||||
<c-type>
|
||||
c-ptr >>class
|
||||
c-ptr >>boxed-class
|
||||
[ alien-cell ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
bootstrap-cell >>align-first
|
||||
[ >c-ptr ] >>unboxer-quot
|
||||
"allot_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
\ void* typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-signed-2 ] >>getter
|
||||
[ set-alien-signed-2 ] >>setter
|
||||
2 >>size
|
||||
t >>signed
|
||||
2 >>align
|
||||
2 >>align-first
|
||||
"from_signed_2" >>boxer
|
||||
"to_signed_2" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ short typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-unsigned-2 ] >>getter
|
||||
[ set-alien-unsigned-2 ] >>setter
|
||||
2 >>size
|
||||
2 >>align
|
||||
2 >>align-first
|
||||
"from_unsigned_2" >>boxer
|
||||
"to_unsigned_2" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ ushort typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-signed-1 ] >>getter
|
||||
[ set-alien-signed-1 ] >>setter
|
||||
1 >>size
|
||||
t >>signed
|
||||
1 >>align
|
||||
1 >>align-first
|
||||
"from_signed_1" >>boxer
|
||||
"to_signed_1" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ char typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-unsigned-1 ] >>getter
|
||||
[ set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
1 >>align-first
|
||||
"from_unsigned_1" >>boxer
|
||||
"to_unsigned_1" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ uchar typedef
|
||||
|
||||
<c-type>
|
||||
math:float >>class
|
||||
math:float >>boxed-class
|
||||
[ alien-float ] >>getter
|
||||
[ set-alien-float ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
"from_float" >>boxer
|
||||
"to_float" >>unboxer
|
||||
float-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
\ float typedef
|
||||
|
||||
<c-type>
|
||||
math:float >>class
|
||||
math:float >>boxed-class
|
||||
[ alien-double ] >>getter
|
||||
[ set-alien-double ] >>setter
|
||||
8 >>size
|
||||
8-byte-alignment
|
||||
"from_double" >>boxer
|
||||
"to_double" >>unboxer
|
||||
double-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
\ double typedef
|
||||
|
||||
cell 8 = [
|
||||
! 64bit-vm int
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-signed-4 ] >>getter
|
||||
[ set-alien-signed-4 ] >>setter
|
||||
4 >>size
|
||||
t >>signed
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
"from_signed_4" >>boxer
|
||||
"to_signed_4" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ int typedef
|
||||
|
||||
! 64bit-vm uint
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
fixnum >>boxed-class
|
||||
[ alien-unsigned-4 ] >>getter
|
||||
[ set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
"from_unsigned_4" >>boxer
|
||||
"to_unsigned_4" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ uint typedef
|
||||
|
||||
! 64bit-vm longlong
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-cell ] >>getter
|
||||
[ set-alien-signed-cell ] >>setter
|
||||
8 >>size
|
||||
t >>signed
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
"from_signed_cell" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ longlong typedef
|
||||
|
||||
! 64bit-vm ulonglong
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-cell ] >>getter
|
||||
[ set-alien-unsigned-cell ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
"from_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ ulonglong typedef
|
||||
|
||||
os windows? [
|
||||
\ int lookup-c-type \ long typedef
|
||||
\ uint lookup-c-type \ ulong typedef
|
||||
] [
|
||||
\ longlong lookup-c-type \ long typedef
|
||||
\ ulonglong lookup-c-type \ ulong typedef
|
||||
] if
|
||||
|
||||
\ longlong lookup-c-type \ ptrdiff_t typedef
|
||||
\ longlong lookup-c-type \ intptr_t typedef
|
||||
|
||||
\ ulonglong lookup-c-type \ uintptr_t typedef
|
||||
\ ulonglong lookup-c-type \ size_t typedef
|
||||
] [
|
||||
! 32bit-vm int
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-cell ] >>getter
|
||||
[ set-alien-signed-cell ] >>setter
|
||||
4 >>size
|
||||
t >>signed
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
"from_signed_cell" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ int typedef
|
||||
|
||||
! 32bit-vm uint
|
||||
<c-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-cell ] >>getter
|
||||
[ set-alien-unsigned-cell ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
"from_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ uint typedef
|
||||
|
||||
! 32bit-vm longlong
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-signed-8 ] >>getter
|
||||
[ set-alien-signed-8 ] >>setter
|
||||
8 >>size
|
||||
t >>signed
|
||||
8-byte-alignment
|
||||
"from_signed_8" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ longlong typedef
|
||||
|
||||
! 32bit-vm ulonglong
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
integer >>boxed-class
|
||||
[ alien-unsigned-8 ] >>getter
|
||||
[ set-alien-unsigned-8 ] >>setter
|
||||
8 >>size
|
||||
8-byte-alignment
|
||||
"from_unsigned_8" >>boxer
|
||||
"to_unsigned_8" >>unboxer
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ ulonglong typedef
|
||||
|
||||
\ int lookup-c-type \ long typedef
|
||||
\ uint lookup-c-type \ ulong typedef
|
||||
|
||||
\ int lookup-c-type \ ptrdiff_t typedef
|
||||
\ int lookup-c-type \ intptr_t typedef
|
||||
|
||||
\ uint lookup-c-type \ uintptr_t typedef
|
||||
\ uint lookup-c-type \ size_t typedef
|
||||
] if
|
||||
|
||||
\ uchar lookup-c-type clone
|
||||
[ >c-bool ] >>unboxer-quot
|
||||
[ c-bool> ] >>boxer-quot
|
||||
object >>boxed-class
|
||||
\ bool typedef
|
||||
|
||||
\ char lookup-c-type int8_t typedef
|
||||
\ short lookup-c-type int16_t typedef
|
||||
\ int lookup-c-type int32_t typedef
|
||||
\ longlong lookup-c-type int64_t typedef
|
||||
|
||||
\ uchar lookup-c-type uint8_t typedef
|
||||
\ ushort lookup-c-type uint16_t typedef
|
||||
\ uint lookup-c-type uint32_t typedef
|
||||
\ ulonglong lookup-c-type uint64_t typedef
|
||||
|
||||
] with-compilation-unit
|
||||
|
||||
M: char-16-rep rep-component-type drop char ;
|
||||
M: uchar-16-rep rep-component-type drop uchar ;
|
||||
M: short-8-rep rep-component-type drop short ;
|
||||
M: ushort-8-rep rep-component-type drop ushort ;
|
||||
M: int-4-rep rep-component-type drop int ;
|
||||
M: uint-4-rep rep-component-type drop uint ;
|
||||
M: longlong-2-rep rep-component-type drop longlong ;
|
||||
M: ulonglong-2-rep rep-component-type drop ulonglong ;
|
||||
M: float-4-rep rep-component-type drop float ;
|
||||
M: double-2-rep rep-component-type drop double ;
|
||||
|
||||
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
|
||||
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
|
||||
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
|
||||
: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
|
||||
|
||||
: c-type-interval ( c-type -- from to )
|
||||
{
|
||||
{ [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
|
||||
{ [ dup c-type-signed ] [ signed-interval ] }
|
||||
{ [ dup c-type-signed not ] [ unsigned-interval ] }
|
||||
} cond ; foldable
|
||||
|
||||
: c-type-clamp ( value c-type -- value' )
|
||||
dup { float double } member-eq?
|
||||
[ drop ] [ c-type-interval clamp ] if ; inline
|
||||
|
||||
GENERIC: pointer-string ( pointer -- string/f )
|
||||
M: object pointer-string drop f ;
|
||||
M: word pointer-string name>> ;
|
||||
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
|
||||
|
||||
GENERIC: c-type-string ( c-type -- string )
|
||||
|
||||
M: integer c-type-string number>string ;
|
||||
M: word c-type-string name>> ;
|
||||
M: pointer c-type-string pointer-string ;
|
||||
M: wrapper c-type-string wrapped>> c-type-string ;
|
||||
M: array c-type-string
|
||||
unclip
|
||||
[ [ c-type-string "[" "]" surround ] map ]
|
||||
[ c-type-string ] bi*
|
||||
prefix concat ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
C data type support
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
USING: help.markup help.syntax math ;
|
||||
IN: alien.complex
|
||||
|
||||
HELP: complex-float
|
||||
{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ;
|
||||
HELP: complex-double
|
||||
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ;
|
||||
|
||||
ARTICLE: "alien.complex" "C99 complex number types"
|
||||
"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
|
||||
{ $table
|
||||
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link complex } " values" } }
|
||||
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link complex } " values" } }
|
||||
} ;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.complex classes.struct math
|
||||
namespaces tools.test ;
|
||||
IN: alien.complex.tests
|
||||
|
||||
STRUCT: complex-holder
|
||||
{ z complex-float } ;
|
||||
|
||||
: <complex-holder> ( z -- alien )
|
||||
complex-holder <struct-boa> ;
|
||||
|
||||
{ } [
|
||||
C{ 1.0 2.0 } <complex-holder> "h" set
|
||||
] unit-test
|
||||
|
||||
{ C{ 1.0 2.0 } } [ "h" get z>> ] unit-test
|
||||
|
||||
{ complex } [ complex-float c-type-boxed-class ] unit-test
|
||||
|
||||
{ complex } [ complex-double c-type-boxed-class ] unit-test
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.complex.functor kernel
|
||||
sequences ;
|
||||
IN: alien.complex
|
||||
|
||||
<<
|
||||
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
||||
>>
|
||||
|
||||
<<
|
||||
! This overrides the fact that small structures are never returned
|
||||
! in registers on Linux running on 32-bit x86.
|
||||
\ complex-float lookup-c-type t >>return-in-registers? drop
|
||||
>>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types classes.struct functors
|
||||
kernel math math.functions quotations ;
|
||||
IN: alien.complex.functor
|
||||
|
||||
<FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
N-type IS ${N}
|
||||
|
||||
T-class DEFINES-CLASS ${T}
|
||||
|
||||
<T> DEFINES <${T}>
|
||||
*T DEFINES *${T}
|
||||
|
||||
WHERE
|
||||
|
||||
STRUCT: T-class { real N-type } { imaginary N-type } ;
|
||||
|
||||
: <T> ( z -- alien )
|
||||
>rect T-class <struct-boa> >c-ptr ;
|
||||
|
||||
: *T ( alien -- z )
|
||||
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
|
||||
|
||||
T-class lookup-c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
complex >>boxed-class
|
||||
drop
|
||||
|
||||
;FUNCTOR>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Code generation for C99 complex number support
|
||||
|
|
@ -0,0 +1 @@
|
|||
Implementation details for C99 complex float and complex double types
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,260 @@
|
|||
USING: alien alien.c-types help.syntax help.markup libc
|
||||
kernel.private byte-arrays math strings hashtables alien.syntax
|
||||
alien.strings sequences io.encodings.string debugger destructors
|
||||
vocabs.loader classes.struct quotations kernel ;
|
||||
IN: alien.data
|
||||
|
||||
HELP: >c-array
|
||||
{ $values { "seq" sequence } { "c-type" "a C type" } { "array" byte-array } }
|
||||
{ $description "Outputs a freshly allocated byte-array whose elements are C type values from the given sequence." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alien.c-types alien.data prettyprint ;"
|
||||
"{ 1.0 2.0 3.0 } alien.c-types:float >c-array ."
|
||||
"float-array{ 1.0 2.0 3.0 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <c-array>
|
||||
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
|
||||
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alien.c-types alien.data prettyprint ;"
|
||||
"10 void* <c-array> ."
|
||||
"void*-array{ f f f f f f f f f f }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: c-array{
|
||||
{ $description "Literal syntax, consists of a C-type followed by a series of values terminated by " { $snippet "}" } }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
|
||||
|
||||
HELP: memory>byte-array
|
||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||
|
||||
HELP: cast-array
|
||||
{ $values { "byte-array" byte-array } { "c-type" "a C type" } { "array" "a specialized array" } }
|
||||
{ $description "Converts a " { $link byte-array } " into a specialized array by interpreting the bytes in it as machine-specific values. Code using this word is unportable." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded, otherwise an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
|
||||
|
||||
HELP: malloc-array
|
||||
{ $values { "n" "a non-negative integer" } { "c-type" "a C type" } { "array" "a specialized array" } }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-byte-array
|
||||
{ $values { "byte-array" byte-array } { "alien" alien } }
|
||||
{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if memory allocation fails." } ;
|
||||
|
||||
{ <c-array> <c-direct-array> malloc-array } related-words
|
||||
|
||||
{ string>alien alien>string malloc-string } related-words
|
||||
|
||||
HELP: with-scoped-allocation
|
||||
{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } }
|
||||
{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns."
|
||||
$nl
|
||||
"A scoped allocation specifier is either:"
|
||||
{ $list
|
||||
"a C type name,"
|
||||
{ "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
|
||||
}
|
||||
"If no initial value is specified, the contents of the allocated memory are undefined." }
|
||||
{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors alien.c-types alien.data
|
||||
classes.struct kernel math math.functions
|
||||
prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
STRUCT: test-point { x int } { y int } ;
|
||||
|
||||
: scoped-allocation-test ( -- x )
|
||||
{ test-point } [
|
||||
3 >>x 4 >>y
|
||||
[ x>> sq ] [ y>> sq ] bi + sqrt
|
||||
] with-scoped-allocation ;
|
||||
|
||||
scoped-allocation-test ."
|
||||
"5.0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: with-out-parameters
|
||||
{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } }
|
||||
{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
|
||||
$nl
|
||||
"A scoped allocation specifier is either:"
|
||||
{ $list
|
||||
"a C type name,"
|
||||
{ "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
|
||||
}
|
||||
"If no initial value is specified, the contents of the allocated memory are undefined." }
|
||||
{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ;
|
||||
|
||||
ARTICLE: "malloc" "Manual memory management"
|
||||
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
|
||||
$nl
|
||||
"Allocating a C datum with a fixed address:"
|
||||
{ $subsections
|
||||
malloc-byte-array
|
||||
}
|
||||
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
|
||||
{ $subsections
|
||||
malloc
|
||||
calloc
|
||||
realloc
|
||||
}
|
||||
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||
{ $subsections free }
|
||||
"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:"
|
||||
{ $subsections (free) }
|
||||
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
|
||||
{ $subsections
|
||||
&free
|
||||
|free
|
||||
}
|
||||
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
|
||||
$nl
|
||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||
{ $subsections memcpy }
|
||||
"You can copy a range of bytes from memory into a byte array:"
|
||||
{ $subsections memory>byte-array } ;
|
||||
|
||||
ARTICLE: "c-pointers" "Passing pointers to C functions"
|
||||
"The following Factor objects may be passed to C function parameters with pointer types:"
|
||||
{ $list
|
||||
{ "Instances of " { $link alien } "." }
|
||||
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
|
||||
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
|
||||
{ "Any data type which defines a method on " { $link >c-ptr } ". This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
|
||||
}
|
||||
"The class of primitive C pointer types:"
|
||||
{ $subsections c-ptr }
|
||||
"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:"
|
||||
{ $subsections >c-ptr }
|
||||
"More about the " { $link alien } " type:"
|
||||
{ $subsections "aliens" }
|
||||
{ $warning
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
|
||||
|
||||
ARTICLE: "c-boxes" "C value boxes"
|
||||
"Sometimes it is useful to create a byte array storing a single C value, like a struct with a single field. A pair of utility words exist to make this more convenient:"
|
||||
{ $subsections <ref> deref }
|
||||
"These words can be used to in conjunction with, or instead of, " { $link with-out-parameters } " to handle \"out-parameters\". For example, if a function is declared in the following way:"
|
||||
{ $code
|
||||
"FUNCTION: int do_foo ( int* a )"
|
||||
}
|
||||
"and writes to the pointer 'a', then it can be called like this:"
|
||||
{ $code
|
||||
"1234 int <ref> [ do_foo ] keep int deref"
|
||||
}
|
||||
"The stack will then contain the two integers emitted by the 'do_foo' function." ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
$nl
|
||||
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
|
||||
{ $subsections
|
||||
"c-types-specs"
|
||||
"c-pointers"
|
||||
"malloc"
|
||||
"c-strings"
|
||||
"c-out-params"
|
||||
"c-boxes"
|
||||
}
|
||||
"Important guidelines for passing data in byte arrays:"
|
||||
{ $subsections "byte-arrays-gc" }
|
||||
"C-style enumerated types are supported:"
|
||||
{ $subsections "alien.enums" }
|
||||
"A utility for defining " { $link "destructors" } " for deallocating memory:"
|
||||
{ $subsections "alien.destructors" }
|
||||
"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION-STRUCT: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
|
||||
|
||||
HELP: malloc-string
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if one of the following conditions occurs:"
|
||||
{ $list
|
||||
"the string contains null code points"
|
||||
"the string contains characters not representable using the encoding specified"
|
||||
"memory allocation fails"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <c-direct-array>
|
||||
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
|
||||
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
|
||||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"C string types are arrays with shape " { $snippet "{ c-string encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link c-string } " is an alias for " { $snippet "{ c-string utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors. In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, the shorthand syntax " { $snippet "c-string[encoding]" } " can be used to specify the string encoding."
|
||||
$nl
|
||||
"Using C string types triggers automatic conversions:"
|
||||
{ $list
|
||||
{
|
||||
"Passing a Factor string to a C function expecting a " { $link c-string } " allocates a " { $link byte-array } " in the Factor heap; the string is then encoded to the requested encoding and a raw pointer is passed to the function. "
|
||||
"Passing an already encoded " { $link byte-array } " also works and performs no conversion."
|
||||
}
|
||||
{ "Returning a C string from a C function allocates a Factor string in the Factor heap; the memory pointed to by the returned pointer is then decoded with the requested encoding into the Factor string." }
|
||||
{ "Reading " { $link c-string } " slots of " { $link POSTPONE: STRUCT: } " or " { $link POSTPONE: UNION-STRUCT: } " returns Factor strings." }
|
||||
}
|
||||
$nl
|
||||
"Care must be taken if the C function expects a pointer to a string with its length represented by another parameter rather than a null terminator. Passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
||||
$nl
|
||||
"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||
{ $subsections
|
||||
string>alien
|
||||
malloc-string
|
||||
}
|
||||
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
|
||||
$nl
|
||||
"A word to read strings from arbitrary addresses:"
|
||||
{ $subsections alien>string }
|
||||
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;
|
||||
|
||||
HELP: <ref>
|
||||
{ $values { "value" object } { "c-type" "a C type" } { "c-ptr" c-ptr } }
|
||||
{ $description "Creates a new byte array to store a Factor object as a C value." }
|
||||
{ $examples
|
||||
{ $example "USING: alien.c-types alien.data prettyprint sequences ;" "123 int <ref> length ." "4" }
|
||||
} ;
|
||||
|
||||
HELP: deref
|
||||
{ $values { "c-ptr" c-ptr } { "c-type" "a C type" } { "value" object } }
|
||||
{ $description "Loads a C value from a byte array." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: alien.c-types alien.data prettyprint sequences ;"
|
||||
"321 int <ref> int deref ."
|
||||
"321" }
|
||||
} ;
|
||||
|
||||
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."
|
||||
{ $subsection with-out-parameters }
|
||||
"The idiom is commonly used for passing back an error message if the function calls fails. For example, if a function is declared in the following way:"
|
||||
{ $code
|
||||
"FUNCTION: int do_frob ( int arg1, char** errptr )"
|
||||
}
|
||||
"Then it could return 1 on error and 0 otherwise. A correct way to call it would be:"
|
||||
{ $code
|
||||
"1234 { c-string } [ do_frob ] with-out-parameters"
|
||||
}
|
||||
"which would put the function's return value and error string on the stack." ;
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
USING: alien alien.data alien.syntax classes.struct
|
||||
compiler.units kernel sequences specialized-arrays
|
||||
specialized-arrays.private system tools.test vocabs ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: alien.data.tests
|
||||
|
||||
{ -1 } [ -1 c:char <ref> c:char deref ] unit-test
|
||||
{ -1 } [ -1 c:short <ref> c:short deref ] unit-test
|
||||
{ -1 } [ -1 c:int <ref> c:int deref ] unit-test
|
||||
|
||||
! I don't care if this throws an error or works, but at least
|
||||
! it should be consistent between platforms
|
||||
{ -1 } [ -1.0 c:int <ref> c:int deref ] unit-test
|
||||
{ -1 } [ -1.0 c:long <ref> c:long deref ] unit-test
|
||||
{ -1 } [ -1.0 c:longlong <ref> c:longlong deref ] unit-test
|
||||
{ 1 } [ 1.0 c:uint <ref> c:uint deref ] unit-test
|
||||
{ 1 } [ 1.0 c:ulong <ref> c:ulong deref ] unit-test
|
||||
{ 1 } [ 1.0 c:ulonglong <ref> c:ulonglong deref ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> c:void* <ref>
|
||||
] must-fail
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 c:long <ref> c:long deref ] unit-test
|
||||
] when
|
||||
|
||||
STRUCT: foo { a c:int } { b c:void* } { c c:bool } ;
|
||||
|
||||
SPECIALIZED-ARRAY: foo
|
||||
|
||||
{ t } [ 0 binary-zero? ] unit-test
|
||||
{ f } [ 1 binary-zero? ] unit-test
|
||||
{ f } [ -1 binary-zero? ] unit-test
|
||||
{ t } [ 0.0 binary-zero? ] unit-test
|
||||
{ f } [ 1.0 binary-zero? ] unit-test
|
||||
{ f } [ -0.0 binary-zero? ] unit-test
|
||||
{ t } [ C{ 0.0 0.0 } binary-zero? ] unit-test
|
||||
{ f } [ C{ 1.0 0.0 } binary-zero? ] unit-test
|
||||
{ f } [ C{ -0.0 0.0 } binary-zero? ] unit-test
|
||||
{ f } [ C{ 0.0 1.0 } binary-zero? ] unit-test
|
||||
{ f } [ C{ 0.0 -0.0 } binary-zero? ] unit-test
|
||||
{ t } [ f binary-zero? ] unit-test
|
||||
{ t } [ 0 <alien> binary-zero? ] unit-test
|
||||
{ f } [ 1 <alien> binary-zero? ] unit-test
|
||||
{ f } [ B{ } binary-zero? ] unit-test
|
||||
{ t } [ S{ foo f 0 f f } binary-zero? ] unit-test
|
||||
{ f } [ S{ foo f 1 f f } binary-zero? ] unit-test
|
||||
{ f } [ S{ foo f 0 ALIEN: 8 f } binary-zero? ] unit-test
|
||||
{ f } [ S{ foo f 0 f t } binary-zero? ] unit-test
|
||||
{ t t f } [
|
||||
foo-array{
|
||||
S{ foo f 0 f f }
|
||||
S{ foo f 0 f f }
|
||||
S{ foo f 1 f f }
|
||||
} [ first binary-zero? ] [ second binary-zero? ] [ third binary-zero? ] tri
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
[
|
||||
foo specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,179 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.arrays alien.c-types alien.strings
|
||||
arrays byte-arrays combinators combinators.short-circuit
|
||||
cpu.architecture fry generalizations io io.streams.memory kernel
|
||||
libc locals macros math math.functions parser sequences
|
||||
stack-checker.dependencies summary words ;
|
||||
IN: alien.data
|
||||
|
||||
: <ref> ( value c-type -- c-ptr )
|
||||
[ heap-size (byte-array) ] keep
|
||||
'[ 0 _ set-alien-value ] keep ; inline
|
||||
|
||||
: deref ( c-ptr c-type -- value )
|
||||
[ 0 ] dip alien-value ; inline
|
||||
|
||||
: little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
|
||||
|
||||
GENERIC: c-array-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-(array)-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-array-type ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-array-type? ( c-type -- word ) foldable
|
||||
|
||||
GENERIC: c-array? ( obj c-type -- ? ) foldable
|
||||
|
||||
M: word c-array?
|
||||
c-array-type? execute( seq -- array ) ; inline
|
||||
|
||||
M: pointer c-array?
|
||||
drop void* c-array? ;
|
||||
|
||||
GENERIC: >c-array ( seq c-type -- array )
|
||||
|
||||
M: word >c-array
|
||||
c-array-type new clone-like ; inline
|
||||
|
||||
M: pointer >c-array
|
||||
drop void* >c-array ;
|
||||
|
||||
GENERIC: <c-array> ( len c-type -- array )
|
||||
|
||||
M: word <c-array>
|
||||
c-array-constructor execute( len -- array ) ; inline
|
||||
|
||||
M: pointer <c-array>
|
||||
drop void* <c-array> ;
|
||||
|
||||
GENERIC: (c-array) ( len c-type -- array )
|
||||
|
||||
M: word (c-array)
|
||||
c-(array)-constructor execute( len -- array ) ; inline
|
||||
|
||||
M: pointer (c-array)
|
||||
drop void* (c-array) ;
|
||||
|
||||
GENERIC: <c-direct-array> ( alien len c-type -- array )
|
||||
|
||||
M: word <c-direct-array>
|
||||
c-direct-array-constructor execute( alien len -- array ) ; inline
|
||||
|
||||
M: pointer <c-direct-array>
|
||||
drop void* <c-direct-array> ;
|
||||
|
||||
SYNTAX: c-array{ \ } [ unclip >c-array ] parse-literal ;
|
||||
|
||||
SYNTAX: c-array@
|
||||
scan-object [ scan-object scan-object ] dip
|
||||
<c-direct-array> suffix! ;
|
||||
|
||||
ERROR: bad-byte-array-length byte-array type ;
|
||||
|
||||
M: bad-byte-array-length summary
|
||||
drop "Byte array length doesn't divide type width" ;
|
||||
|
||||
: cast-array ( byte-array c-type -- array )
|
||||
[ binary-object ] dip [ heap-size /mod 0 = ] keep swap
|
||||
[ <c-direct-array> ] [ bad-byte-array-length ] if ; inline
|
||||
|
||||
: malloc-array ( n c-type -- array )
|
||||
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
|
||||
|
||||
: malloc-like ( seq c-type -- malloc )
|
||||
[ dup length ] dip malloc-array [ 0 swap copy ] keep ;
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
binary-object [ nip malloc dup ] 2keep memcpy ;
|
||||
|
||||
: memory>byte-array ( alien len -- byte-array )
|
||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||
|
||||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
M:: memory-stream stream-read-unsafe ( n buf stream -- count )
|
||||
stream alien>> :> src
|
||||
buf src n memcpy
|
||||
n src <displaced-alien> stream alien<<
|
||||
n ; inline
|
||||
|
||||
M: value-type c-type-rep drop int-rep ;
|
||||
|
||||
M: value-type c-type-getter
|
||||
drop [ swap <displaced-alien> ] ;
|
||||
|
||||
M: value-type c-type-copier
|
||||
heap-size '[ _ memory>byte-array ] ;
|
||||
|
||||
M: value-type c-type-setter
|
||||
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
|
||||
|
||||
M: array c-type-boxer-quot
|
||||
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
ERROR: local-allocation-error ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (local-allot) ( size align -- alien ) local-allocation-error ;
|
||||
|
||||
: (cleanup-allot) ( -- )
|
||||
! Inhibit TCO in order for the last word in the quotation
|
||||
! to still be able to access scope-allocated data.
|
||||
;
|
||||
|
||||
MACRO: (simple-local-allot) ( c-type -- quot )
|
||||
[ add-depends-on-c-type ]
|
||||
[ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
|
||||
|
||||
: [hairy-local-allot] ( c-type initial -- quot )
|
||||
over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
|
||||
|
||||
: hairy-local-allot? ( obj -- ? )
|
||||
{
|
||||
[ array? ]
|
||||
[ length 3 = ]
|
||||
[ second initial: eq? ]
|
||||
} 1&& ;
|
||||
|
||||
MACRO: (hairy-local-allot) ( obj -- quot )
|
||||
dup hairy-local-allot?
|
||||
[ first3 nip [hairy-local-allot] ]
|
||||
[ '[ _ (simple-local-allot) ] ]
|
||||
if ;
|
||||
|
||||
MACRO: (local-allots) ( c-types -- quot )
|
||||
[ '[ _ (hairy-local-allot) ] ] map [ ] join ;
|
||||
|
||||
MACRO: box-values ( c-types -- quot )
|
||||
[ c-type-boxer-quot ] map '[ _ spread ] ;
|
||||
|
||||
MACRO: out-parameters ( c-types -- quot )
|
||||
[ dup hairy-local-allot? [ first ] when ] map
|
||||
[ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
|
||||
'[ _ nkeep _ spread ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-scoped-allocation ( c-types quot -- )
|
||||
[ [ (local-allots) ] [ box-values ] bi ] dip call
|
||||
(cleanup-allot) ; inline
|
||||
|
||||
: with-out-parameters ( c-types quot -- values... )
|
||||
[ drop (local-allots) ] [ swap out-parameters ] 2bi
|
||||
(cleanup-allot) ; inline
|
||||
|
||||
GENERIC: binary-zero? ( value -- ? )
|
||||
|
||||
M: object binary-zero? drop f ; inline
|
||||
M: f binary-zero? drop t ; inline
|
||||
M: integer binary-zero? zero? ; inline
|
||||
M: math:float binary-zero? double>bits zero? ; inline
|
||||
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
Words for allocating objects and arrays of C types
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
IN: alien.destructors
|
||||
USING: help.markup help.syntax alien destructors ;
|
||||
|
||||
HELP: DESTRUCTOR:
|
||||
{ $syntax "DESTRUCTOR: word" }
|
||||
{ $description "Defines four things:"
|
||||
{ $list
|
||||
{ "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
|
||||
{ "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
|
||||
{ "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
|
||||
}
|
||||
"The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
|
||||
}
|
||||
{ $examples
|
||||
"Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
|
||||
{ $code
|
||||
"FUNCTION: void g_object_unref ( gpointer object ) ;"
|
||||
"DESTRUCTOR: g_object_unref"
|
||||
}
|
||||
"Now, memory management becomes easier:"
|
||||
{ $code
|
||||
"[ g_new_foo &g_object_unref ... ] with-destructors"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "alien.destructors" "Alien destructors"
|
||||
"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
|
||||
{ $subsections POSTPONE: DESTRUCTOR: } ;
|
||||
|
||||
ABOUT: "alien.destructors"
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors destructors effects functors generalizations
|
||||
kernel parser sequences ;
|
||||
IN: alien.destructors
|
||||
|
||||
TUPLE: alien-destructor alien ;
|
||||
|
||||
<FUNCTOR: define-destructor ( F -- )
|
||||
|
||||
F-destructor DEFINES-CLASS ${F}-destructor
|
||||
<F-destructor> DEFINES <${F}-destructor>
|
||||
&F DEFINES &${F}
|
||||
|F DEFINES |${F}
|
||||
N [ F stack-effect out>> length ]
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: F-destructor < alien-destructor ;
|
||||
|
||||
: <F-destructor> ( alien -- destructor )
|
||||
F-destructor boa ; inline
|
||||
|
||||
M: F-destructor dispose alien>> F N ndrop ;
|
||||
|
||||
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
|
||||
|
||||
: |F ( alien -- alien ) dup <F-destructor> |dispose drop ; inline
|
||||
|
||||
;FUNCTOR>
|
||||
|
||||
SYNTAX: DESTRUCTOR: scan-word define-destructor ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Functor for defining destructors which call a C function to dispose of resources
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
! Copyright (C) 2011 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel math quotations
|
||||
classes.struct ;
|
||||
IN: alien.endian
|
||||
|
||||
HELP: BE-PACKED-STRUCT:
|
||||
{ $description "Defines a packed " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
|
||||
{ $unchecked-example
|
||||
"! When run on a big-endian platform, this struct should prettyprint the same as defined"
|
||||
"! The output of this example is from a little-endian platform"
|
||||
"USE: alien.endian"
|
||||
"BE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
|
||||
"\\ s1 see"
|
||||
"USING: alien.c-types alien.endian classes.struct ;
|
||||
IN: scratchpad
|
||||
STRUCT: s1 { a char[7] } { b be32 initial: 0 } ;"
|
||||
} ;
|
||||
|
||||
HELP: BE-STRUCT:
|
||||
{ $description "Defines a " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
|
||||
{ $unchecked-example
|
||||
"! When run on a big-endian platform, this struct should prettyprint the same as defined"
|
||||
"! The output of this example is from a little-endian platform"
|
||||
"USE: alien.endian"
|
||||
"BE-STRUCT: s1 { a int } { b le32 } ;"
|
||||
"\\ s1 see"
|
||||
"USING: alien.c-types alien.endian classes.struct ;
|
||||
IN: scratchpad
|
||||
STRUCT: s1 { a be32 initial: 0 } { b le32 initial: 0 } ;"
|
||||
} ;
|
||||
|
||||
HELP: LE-PACKED-STRUCT:
|
||||
{ $description "Defines a packed " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
|
||||
{ $unchecked-example
|
||||
"! When run on a little-endian platform, this struct should prettyprint the same as defined"
|
||||
"! The output of this example is from a little-endian platform"
|
||||
"USE: alien.endian"
|
||||
"LE-PACKED-STRUCT: s1 { a char[7] } { b int } ;"
|
||||
"\\ s1 see"
|
||||
"USING: alien.c-types alien.endian classes.struct ;
|
||||
IN: scratchpad
|
||||
STRUCT: s1 { a char[7] } { b int initial: 0 } ;"
|
||||
} ;
|
||||
|
||||
HELP: LE-STRUCT:
|
||||
{ $description "Defines a " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." }
|
||||
{ $unchecked-example
|
||||
"! When run on a little-endian platform, this struct should prettyprint the same as defined"
|
||||
"! The output of this example is from a little-endian platform"
|
||||
"USE: alien.endian"
|
||||
"LE-STRUCT: s1 { a int } { b be32 } ;"
|
||||
"\\ s1 see"
|
||||
"USING: alien.c-types alien.endian classes.struct ;
|
||||
IN: scratchpad
|
||||
STRUCT: s1 { a int initial: 0 } { b be32 initial: 0 } ;"
|
||||
} ;
|
||||
|
||||
HELP: be16
|
||||
{ $var-description "Signed bit-endian 16-bit." } ;
|
||||
|
||||
HELP: be32
|
||||
{ $var-description "Signed bit-endian 32-bit." } ;
|
||||
|
||||
HELP: be64
|
||||
{ $var-description "Signed bit-endian 64-bit." } ;
|
||||
|
||||
HELP: be8
|
||||
{ $var-description "Signed bit-endian 8-bit." } ;
|
||||
|
||||
HELP: byte-reverse
|
||||
{ $values
|
||||
{ "n" integer } { "signed?" boolean }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Reverses the " { $snippet "n" } " bytes in an integer with bitwise operations. The second parameter only works for 1, 2, 4, or 8 byte signed numbers." } ;
|
||||
|
||||
HELP: le16
|
||||
{ $var-description "Signed little-endian 16-bit." } ;
|
||||
|
||||
HELP: le32
|
||||
{ $var-description "Signed little-endian 32-bit." } ;
|
||||
|
||||
HELP: le64
|
||||
{ $var-description "Signed little-endian 64-bit." } ;
|
||||
|
||||
HELP: le8
|
||||
{ $var-description "Signed little-endian 8-bit." } ;
|
||||
|
||||
HELP: ube16
|
||||
{ $var-description "Unsigned big-endian 16-bit." } ;
|
||||
|
||||
HELP: ube32
|
||||
{ $var-description "Unsigned big-endian 32-bit." } ;
|
||||
|
||||
HELP: ube64
|
||||
{ $var-description "Unsigned big-endian 64-bit." } ;
|
||||
|
||||
HELP: ube8
|
||||
{ $var-description "Unsigned big-endian 8-bit." } ;
|
||||
|
||||
HELP: ule16
|
||||
{ $var-description "Unsigned little-endian 16-bit." } ;
|
||||
|
||||
HELP: ule32
|
||||
{ $var-description "Unsigned little-endian 32-bit." } ;
|
||||
|
||||
HELP: ule64
|
||||
{ $var-description "Unsigned little-endian 64-bit." } ;
|
||||
|
||||
HELP: ule8
|
||||
{ $var-description "Unsigned little-endian 8-bit." } ;
|
||||
|
||||
ARTICLE: "alien.endian" "Alien endian-aware types"
|
||||
"The " { $vocab-link "alien.endian" } " vocabulary defines c-types that are endian-aware for use in structs. These types will cause the bytes in a byte-array to be interpreted as little or big-endian transparently when reading or writing. There are both signed and unsigned types defined; signed is the default while unsigned are prefixed with a " { $snippet "u" } ". The intended use-case is for network protocols in network-byte-order (big-endian)." $nl
|
||||
"Byte-reversal of integers:"
|
||||
{ $subsections
|
||||
byte-reverse
|
||||
}
|
||||
"The big-endian c-types are:"
|
||||
{ $subsections
|
||||
be8
|
||||
be16
|
||||
be32
|
||||
be64
|
||||
ube8
|
||||
ube16
|
||||
ube32
|
||||
ube64
|
||||
}
|
||||
"The little-endian c-types are:"
|
||||
{ $subsections
|
||||
le8
|
||||
le16
|
||||
le32
|
||||
le64
|
||||
ule8
|
||||
ule16
|
||||
ule32
|
||||
ule64
|
||||
}
|
||||
"Syntax for making endian-aware structs out of native types:"
|
||||
{ $subsections
|
||||
POSTPONE: LE-STRUCT:
|
||||
POSTPONE: BE-STRUCT:
|
||||
POSTPONE: LE-PACKED-STRUCT:
|
||||
POSTPONE: BE-PACKED-STRUCT:
|
||||
} ;
|
||||
|
||||
ABOUT: "alien.endian"
|
||||
|
|
@ -0,0 +1,239 @@
|
|||
! Copyright (C) 2011 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.endian classes.struct io
|
||||
io.encodings.binary io.streams.byte-array kernel tools.test ;
|
||||
IN: alien.endian.tests
|
||||
|
||||
STRUCT: endian-struct
|
||||
{ a ule16 }
|
||||
{ b le16 }
|
||||
{ c ube16 }
|
||||
{ d be16 }
|
||||
{ e ule32 }
|
||||
{ f le32 }
|
||||
{ g ube32 }
|
||||
{ h be32 }
|
||||
{ i ule64 }
|
||||
{ j le64 }
|
||||
{ k ube64 }
|
||||
{ l be64 } ;
|
||||
|
||||
CONSTANT: endian-bytes-0f B{
|
||||
0x0 0xff
|
||||
0x0 0xff
|
||||
0x0 0xff
|
||||
0x0 0xff
|
||||
|
||||
0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0xff
|
||||
|
||||
0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
|
||||
0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff
|
||||
}
|
||||
|
||||
CONSTANT: endian-bytes-f0 B{
|
||||
0xff 0x0
|
||||
0xff 0x0
|
||||
0xff 0x0
|
||||
0xff 0x0
|
||||
|
||||
0xff 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0
|
||||
|
||||
0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
|
||||
0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0
|
||||
}
|
||||
|
||||
: endian-test-struct-0f ( -- obj )
|
||||
endian-bytes-0f endian-struct memory>struct ;
|
||||
|
||||
: endian-test-struct-f0 ( -- obj )
|
||||
endian-bytes-f0 endian-struct memory>struct ;
|
||||
|
||||
{ 0xff00 } [ endian-test-struct-0f a>> ] unit-test
|
||||
{ -256 } [ endian-test-struct-0f b>> ] unit-test
|
||||
{ 0x00ff } [ endian-test-struct-0f c>> ] unit-test
|
||||
{ 0x00ff } [ endian-test-struct-0f d>> ] unit-test
|
||||
|
||||
{ 0xff000000 } [ endian-test-struct-0f e>> ] unit-test
|
||||
{ -16777216 } [ endian-test-struct-0f f>> ] unit-test
|
||||
{ 0x000000ff } [ endian-test-struct-0f g>> ] unit-test
|
||||
{ 0x000000ff } [ endian-test-struct-0f h>> ] unit-test
|
||||
|
||||
{ 0xff00000000000000 } [ endian-test-struct-0f i>> ] unit-test
|
||||
{ -72057594037927936 } [ endian-test-struct-0f j>> ] unit-test
|
||||
{ 0x00000000000000ff } [ endian-test-struct-0f k>> ] unit-test
|
||||
{ 0x00000000000000ff } [ endian-test-struct-0f l>> ] unit-test
|
||||
|
||||
|
||||
{ 0xff00 } [ endian-test-struct-f0 c>> ] unit-test
|
||||
{ -256 } [ endian-test-struct-f0 d>> ] unit-test
|
||||
{ 0x00ff } [ endian-test-struct-f0 a>> ] unit-test
|
||||
{ 0x00ff } [ endian-test-struct-f0 b>> ] unit-test
|
||||
|
||||
{ 0xff000000 } [ endian-test-struct-f0 g>> ] unit-test
|
||||
{ -16777216 } [ endian-test-struct-f0 h>> ] unit-test
|
||||
{ 0x000000ff } [ endian-test-struct-f0 e>> ] unit-test
|
||||
{ 0x000000ff } [ endian-test-struct-f0 f>> ] unit-test
|
||||
|
||||
{ 0xff00000000000000 } [ endian-test-struct-f0 k>> ] unit-test
|
||||
{ -72057594037927936 } [ endian-test-struct-f0 l>> ] unit-test
|
||||
{ 0x00000000000000ff } [ endian-test-struct-f0 i>> ] unit-test
|
||||
{ 0x00000000000000ff } [ endian-test-struct-f0 j>> ] unit-test
|
||||
|
||||
{ t }
|
||||
[ endian-test-struct-0f binary [ write ] with-byte-writer endian-bytes-0f = ] unit-test
|
||||
|
||||
{ t }
|
||||
[ endian-test-struct-f0 binary [ write ] with-byte-writer endian-bytes-f0 = ] unit-test
|
||||
|
||||
LE-STRUCT: le-endian-struct
|
||||
{ a ule16 }
|
||||
{ b le16 }
|
||||
{ c ube16 }
|
||||
{ d be16 }
|
||||
{ e ule32 }
|
||||
{ f le32 }
|
||||
{ g ube32 }
|
||||
{ h be32 }
|
||||
{ i ule64 }
|
||||
{ j le64 }
|
||||
{ k ube64 }
|
||||
{ l be64 } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-0f le-endian-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-0f =
|
||||
] unit-test
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-f0 le-endian-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-f0 =
|
||||
] unit-test
|
||||
|
||||
|
||||
BE-STRUCT: be-endian-struct
|
||||
{ a ule16 }
|
||||
{ b le16 }
|
||||
{ c ube16 }
|
||||
{ d be16 }
|
||||
{ e ule32 }
|
||||
{ f le32 }
|
||||
{ g ube32 }
|
||||
{ h be32 }
|
||||
{ i ule64 }
|
||||
{ j le64 }
|
||||
{ k ube64 }
|
||||
{ l be64 } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-0f be-endian-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-0f =
|
||||
] unit-test
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-f0 be-endian-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-f0 =
|
||||
] unit-test
|
||||
|
||||
LE-STRUCT: le-override-struct
|
||||
{ a ushort }
|
||||
{ b short }
|
||||
{ c ube16 }
|
||||
{ d be16 }
|
||||
{ e uint }
|
||||
{ f int }
|
||||
{ g ube32 }
|
||||
{ h be32 }
|
||||
{ i ulonglong }
|
||||
{ j longlong }
|
||||
{ k ube64 }
|
||||
{ l be64 } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-0f le-override-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-0f =
|
||||
] unit-test
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-f0 le-override-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-f0 =
|
||||
] unit-test
|
||||
|
||||
BE-STRUCT: be-override-struct
|
||||
{ a ule16 }
|
||||
{ b le16 }
|
||||
{ c ushort }
|
||||
{ d short }
|
||||
{ e ule32 }
|
||||
{ f le32 }
|
||||
{ g uint }
|
||||
{ h int }
|
||||
{ i ule64 }
|
||||
{ j le64 }
|
||||
{ k ulonglong }
|
||||
{ l longlong } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-0f be-override-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-0f =
|
||||
] unit-test
|
||||
|
||||
{ t }
|
||||
[
|
||||
endian-bytes-f0 be-override-struct memory>struct
|
||||
binary [ write ] with-byte-writer endian-bytes-f0 =
|
||||
] unit-test
|
||||
|
||||
|
||||
LE-PACKED-STRUCT: le-packed-struct
|
||||
{ a char[7] }
|
||||
{ b int } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
B{ 0 0 0 0 0 0 0 3 0 0 0 } [
|
||||
le-packed-struct memory>struct
|
||||
binary [ write ] with-byte-writer
|
||||
] keep =
|
||||
] unit-test
|
||||
|
||||
{ 3 }
|
||||
[
|
||||
B{ 0 0 0 0 0 0 0 3 0 0 0 } le-packed-struct memory>struct
|
||||
b>>
|
||||
] unit-test
|
||||
|
||||
|
||||
BE-PACKED-STRUCT: be-packed-struct
|
||||
{ a char[7] }
|
||||
{ b int } ;
|
||||
|
||||
{ t }
|
||||
[
|
||||
B{ 0 0 0 0 0 0 0 0 0 0 3 } [
|
||||
be-packed-struct memory>struct
|
||||
binary [ write ] with-byte-writer
|
||||
] keep =
|
||||
] unit-test
|
||||
|
||||
{ 3 }
|
||||
[
|
||||
B{ 0 0 0 0 0 0 0 0 0 0 3 } be-packed-struct memory>struct
|
||||
b>>
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,164 @@
|
|||
! Copyright (C) 2011 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.accessors alien.c-types alien.data arrays
|
||||
classes.struct.private combinators compiler.units endian fry
|
||||
generalizations kernel macros math math.bitwise namespaces
|
||||
sequences slots words ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: alien.endian
|
||||
|
||||
ERROR: invalid-signed-conversion n ;
|
||||
|
||||
: convert-signed-quot ( n -- quot )
|
||||
{
|
||||
{ 1 [ [ char <ref> char deref ] ] }
|
||||
{ 2 [ [ c:short <ref> c:short deref ] ] }
|
||||
{ 4 [ [ int <ref> int deref ] ] }
|
||||
{ 8 [ [ longlong <ref> longlong deref ] ] }
|
||||
[ invalid-signed-conversion ]
|
||||
} case ; inline
|
||||
|
||||
MACRO: byte-reverse ( n signed? -- quot )
|
||||
[
|
||||
drop
|
||||
[
|
||||
dup <iota> [
|
||||
[ 1 + - -8 * ] [ nip 8 * ] 2bi
|
||||
'[ _ shift 0xff bitand _ shift ]
|
||||
] with map
|
||||
] [ 1 - [ bitor ] n*quot ] bi
|
||||
] [
|
||||
[ convert-signed-quot ] [ drop [ ] ] if
|
||||
] 2bi
|
||||
'[ _ cleave @ @ ] ;
|
||||
|
||||
SYMBOLS: le8 be8 ule8 ube8
|
||||
ule16 ule32 ule64 ube16 ube32 ube64
|
||||
le16 le32 le64 be16 be32 be64 ;
|
||||
|
||||
: endian-c-type? ( symbol -- ? )
|
||||
{
|
||||
le8 be8 ule8 ube8 ule16 ule32 ule64
|
||||
ube16 ube32 ube64 le16 le32 le64 be16 be32 be64
|
||||
} member? ;
|
||||
|
||||
ERROR: unknown-endian-c-type symbol ;
|
||||
|
||||
: endian-c-type>c-type-symbol ( symbol -- symbol' )
|
||||
{
|
||||
{ [ dup { ule16 ube16 } member? ] [ drop ushort ] }
|
||||
{ [ dup { le16 be16 } member? ] [ drop c:short ] }
|
||||
{ [ dup { ule32 ube32 } member? ] [ drop uint ] }
|
||||
{ [ dup { le32 be32 } member? ] [ drop int ] }
|
||||
{ [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
|
||||
{ [ dup { le64 be64 } member? ] [ drop longlong ] }
|
||||
[ unknown-endian-c-type ]
|
||||
} cond ;
|
||||
|
||||
: change-c-type-accessors ( n ? c-type -- c-type' )
|
||||
endian-c-type>c-type-symbol "c-type" word-prop clone
|
||||
-rot over 8 = [
|
||||
[
|
||||
nip
|
||||
[
|
||||
[
|
||||
[ alien-unsigned-4 4 f byte-reverse 32 shift ]
|
||||
[ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
|
||||
]
|
||||
] dip [ [ 64 >signed ] compose ] when
|
||||
>>getter drop
|
||||
]
|
||||
[ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
|
||||
] [
|
||||
[ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
|
||||
[ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
|
||||
] if ;
|
||||
|
||||
: typedef-endian ( n ? c-type endian -- )
|
||||
native-endianness get = [
|
||||
2nip [ endian-c-type>c-type-symbol ] keep typedef
|
||||
] [
|
||||
[ change-c-type-accessors ] keep typedef
|
||||
] if ;
|
||||
|
||||
: typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
|
||||
: typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
|
||||
|
||||
[
|
||||
\ char \ le8 typedef
|
||||
\ char \ be8 typedef
|
||||
\ uchar \ ule8 typedef
|
||||
\ uchar \ ube8 typedef
|
||||
2 f \ ule16 typedef-le
|
||||
2 f \ ube16 typedef-be
|
||||
2 t \ le16 typedef-le
|
||||
2 t \ be16 typedef-be
|
||||
4 f \ ule32 typedef-le
|
||||
4 f \ ube32 typedef-be
|
||||
4 t \ le32 typedef-le
|
||||
4 t \ be32 typedef-be
|
||||
8 f \ ule64 typedef-le
|
||||
8 f \ ube64 typedef-be
|
||||
8 t \ le64 typedef-le
|
||||
8 t \ be64 typedef-be
|
||||
] with-compilation-unit
|
||||
|
||||
! pair: { le be }
|
||||
: pair>c-type ( pair -- c-type )
|
||||
[ native-endianness get big-endian = ] dip first2 ? ;
|
||||
|
||||
! endian is desired endian type. if we match endianness, return the c type
|
||||
! otherwise return the opposite of our endianness
|
||||
: endian-slot ( endian c-type pair -- endian-slot )
|
||||
[ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
|
||||
|
||||
ERROR: unsupported-endian-type endian slot ;
|
||||
|
||||
: slot>endian-slot ( endian slot -- endian-slot )
|
||||
dup array? [
|
||||
first2 [ slot>endian-slot ] dip 2array
|
||||
] [
|
||||
{
|
||||
{ [ dup bool = ] [ 2drop bool ] }
|
||||
{ [ dup char = ] [ 2drop char ] }
|
||||
{ [ dup uchar = ] [ 2drop uchar ] }
|
||||
{ [ dup c:short = ] [ { le16 be16 } endian-slot ] }
|
||||
{ [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
|
||||
{ [ dup int = ] [ { le32 be32 } endian-slot ] }
|
||||
{ [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
|
||||
{ [ dup longlong = ] [ { le64 be64 } endian-slot ] }
|
||||
{ [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] }
|
||||
{ [ dup endian-c-type? ] [ nip ] }
|
||||
{ [ dup pointer? ] [ nip ] }
|
||||
[ unsupported-endian-type ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: set-endian-slots ( endian slots -- slot-specs )
|
||||
[ [ slot>endian-slot ] change-type ] with map ;
|
||||
|
||||
: define-endian-struct-class ( class slots endian -- )
|
||||
swap make-slots set-endian-slots
|
||||
[ compute-struct-offsets ] [ struct-alignment ]
|
||||
(define-struct-class) ;
|
||||
|
||||
: define-endian-packed-struct-class ( class slots endian -- )
|
||||
swap make-packed-slots set-endian-slots
|
||||
[ compute-struct-offsets ] [ drop 1 ]
|
||||
(define-struct-class) ;
|
||||
|
||||
SYNTAX: LE-STRUCT:
|
||||
parse-struct-definition
|
||||
little-endian define-endian-struct-class ;
|
||||
|
||||
SYNTAX: BE-STRUCT:
|
||||
parse-struct-definition
|
||||
big-endian define-endian-struct-class ;
|
||||
|
||||
SYNTAX: LE-PACKED-STRUCT:
|
||||
parse-struct-definition
|
||||
little-endian define-endian-packed-struct-class ;
|
||||
|
||||
SYNTAX: BE-PACKED-STRUCT:
|
||||
parse-struct-definition
|
||||
big-endian define-endian-packed-struct-class ;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2010 Erik Charlebois.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax help.markup help.syntax words ;
|
||||
IN: alien.enums
|
||||
|
||||
HELP: define-enum
|
||||
{ $values
|
||||
{ "word" word } { "base-type" c-type } { "members" "sequence of word and value pairs" }
|
||||
}
|
||||
{ $description "Defines an enum. This is the run-time equivalent of " { $link POSTPONE: ENUM: } "." } ;
|
||||
|
||||
HELP: enum>number
|
||||
{ $values
|
||||
{ "enum" "an enum word" }
|
||||
{ "number" "the corresponding number value" }
|
||||
}
|
||||
{ $description "Converts an enum to a number." } ;
|
||||
|
||||
HELP: number>enum
|
||||
{ $values
|
||||
{ "number" "an enum number" } { "enum-c-type" "an enum type" }
|
||||
{ "enum" "the corresponding enum word" }
|
||||
}
|
||||
{ $description "Convert a number to an enum." } ;
|
||||
|
||||
{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
|
||||
|
||||
ABOUT: "alien.enums"
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
! Copyright (C) 2010 Erik Charlebois.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.enums alien.enums.private
|
||||
alien.syntax sequences tools.test words ;
|
||||
IN: alien.enums.tests
|
||||
|
||||
ENUM: color_t red { green 3 } blue ;
|
||||
ENUM: instrument_t < ushort trombone trumpet ;
|
||||
|
||||
{ { red green blue 5 } }
|
||||
[ { 0 3 4 5 } [ <color_t> ] map ] unit-test
|
||||
|
||||
{ { 0 3 4 5 } }
|
||||
[ { red green blue 5 } [ enum>number ] map ] unit-test
|
||||
|
||||
{ { -1 trombone trumpet } }
|
||||
[ { -1 0 1 } [ <instrument_t> ] map ] unit-test
|
||||
|
||||
{ { -1 0 1 } }
|
||||
[ { -1 trombone trumpet } [ enum>number ] map ] unit-test
|
||||
|
||||
{ t }
|
||||
[ color_t "c-type" word-prop enum-c-type? ] unit-test
|
||||
|
||||
{ f }
|
||||
[ ushort "c-type" word-prop enum-c-type? ] unit-test
|
||||
|
||||
{ int }
|
||||
[ color_t "c-type" word-prop base-type>> ] unit-test
|
||||
|
||||
{ ushort }
|
||||
[ instrument_t "c-type" word-prop base-type>> ] unit-test
|
||||
|
||||
{ V{ { red 0 } { green 3 } { blue 4 } } }
|
||||
[ color_t "c-type" word-prop members>> ] unit-test
|
||||
|
||||
ENUM: colores { rojo red } { verde green } { azul blue } { colorado rojo } ;
|
||||
|
||||
{ { 0 3 4 0 } } [ { rojo verde azul colorado } [ enum>number ] map ] unit-test
|
||||
|
||||
SYMBOLS: couleurs rouge vert bleu jaune azure ;
|
||||
|
||||
<< \ couleurs int {
|
||||
{ rouge red }
|
||||
{ vert green }
|
||||
{ bleu blue }
|
||||
{ jaune 14 }
|
||||
{ azure bleu }
|
||||
} define-enum >>
|
||||
|
||||
{ { 0 3 4 14 4 } } [ { rouge vert bleu jaune azure } [ enum>number ] map ] unit-test
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
! Copyright (C) 2010 Joe Groff, Erik Charlebois.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types arrays assocs classes.singleton
|
||||
combinators delegate fry kernel macros math parser sequences
|
||||
words ;
|
||||
IN: alien.enums
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: enum-c-type base-type members ;
|
||||
C: <enum-c-type> enum-c-type
|
||||
CONSULT: c-type-protocol enum-c-type
|
||||
base-type>> ;
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: enum>number ( enum -- number ) foldable
|
||||
M: integer enum>number ;
|
||||
M: word enum>number "enum-value" word-prop ;
|
||||
|
||||
<PRIVATE
|
||||
: enum-boxer ( members -- quot )
|
||||
[ first2 swap '[ _ ] 2array ]
|
||||
{ } map-as [ ] suffix '[ _ case ] ;
|
||||
PRIVATE>
|
||||
|
||||
MACRO: number>enum ( enum-c-type -- quot )
|
||||
lookup-c-type members>> enum-boxer ;
|
||||
|
||||
M: enum-c-type c-type-boxed-class drop object ;
|
||||
M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
|
||||
M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
|
||||
M: enum-c-type c-type-setter
|
||||
[ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
|
||||
|
||||
: define-enum-value ( class value -- )
|
||||
enum>number "enum-value" set-word-prop ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: define-enum-members ( members -- )
|
||||
[ first define-singleton-class ] each ;
|
||||
|
||||
: define-enum-constructor ( word -- )
|
||||
[ name>> "<" ">" surround create-word-in ] keep
|
||||
[ number>enum ] curry ( number -- enum ) define-inline ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (define-enum) ( word base-type members -- )
|
||||
[ dup define-enum-constructor ] 2dip
|
||||
[ define-enum-members ]
|
||||
[ <enum-c-type> swap typedef ] bi ;
|
||||
|
||||
: define-enum ( word base-type members -- )
|
||||
[ (define-enum) ]
|
||||
[ [ define-enum-value ] assoc-each ] bi ;
|
||||
|
||||
PREDICATE: enum-c-type-word < c-type-word
|
||||
"c-type" word-prop enum-c-type? ;
|
||||
|
||||
: enum>values ( enum -- seq )
|
||||
"c-type" word-prop members>> values ;
|
||||
|
||||
: enum>keys ( enum -- seq )
|
||||
"c-type" word-prop members>> keys [ name>> ] map ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Joe Groff
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: alien.libraries.finder
|
||||
|
||||
HELP: find-library*
|
||||
{ $values
|
||||
{ "name" "a shared library name" }
|
||||
{ "path/f" { $maybe "filesystem path" } }
|
||||
}
|
||||
{ $description
|
||||
"Returns a filesystem path for a plain shared library name, or f if no library can be found."
|
||||
} ;
|
||||
|
||||
HELP: find-library
|
||||
{ $values
|
||||
{ "name" "a shared library name" }
|
||||
{ "path/library-not-found" "a filesystem path or " { $snippet "name" } }
|
||||
}
|
||||
{ $description
|
||||
"Used to load libraries whose exact filenames is not known in advance:"
|
||||
{ $code
|
||||
"<< \"sqlite\" \"sqlite3\" find-library cdecl add-library >>"
|
||||
}
|
||||
"Note the parse time evaluation with " { $link POSTPONE: << } "."
|
||||
} ;
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
USING: alien alien.libraries.finder tools.test ;
|
||||
IN: alien.libraries.finder
|
||||
|
||||
{ f } [ "dont-exist" find-library* ] unit-test
|
||||
{ "dont-exist" } [ "dont-exist" find-library ] unit-test
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
USING: accessors alien.libraries kernel sequences system vocabs
|
||||
;
|
||||
IN: alien.libraries.finder
|
||||
|
||||
HOOK: find-library* os ( name -- path/f )
|
||||
|
||||
: find-library ( name -- path/library-not-found )
|
||||
dup find-library* [ nip ] when* ;
|
||||
|
||||
: ?update-library ( name path abi -- )
|
||||
pick lookup-library [ dll>> dll-valid? ] [ f ] if* [
|
||||
3drop
|
||||
] [
|
||||
[ find-library ] [ update-library ] bi*
|
||||
] if ;
|
||||
|
||||
! Try to find the library from a list, but if it's not found,
|
||||
! try to open a library that is the first name in that list anyway
|
||||
! or "library_not_found" as a last resort for better debugging.
|
||||
: find-library-from-list ( seq -- path/f )
|
||||
dup [ find-library* ] map-find drop
|
||||
[ ] [ ?first "library_not_found" or ] ?if ;
|
||||
|
||||
"alien.libraries.finder." os name>> append require
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jack Lucas
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
USING: alien.libraries.finder arrays assocs
|
||||
combinators.short-circuit io io.encodings.utf8 io.files
|
||||
io.files.info io.launcher kernel sequences sets splitting system
|
||||
unicode ;
|
||||
IN: alien.libraries.finder.freebsd
|
||||
<PRIVATE
|
||||
|
||||
: parse-ldconfig-lines ( string -- triple )
|
||||
[ ":-" split1 [ drop ] dip
|
||||
"=>" split1 [ [ blank? ] trim ] bi@
|
||||
2array
|
||||
] map ;
|
||||
|
||||
: load-ldconfig-cache ( -- seq )
|
||||
"/sbin/ldconfig -r" utf8 [ lines ] with-process-reader
|
||||
rest parse-ldconfig-lines ;
|
||||
|
||||
: name-matches? ( lib double -- ? )
|
||||
first swap ?head [ ?first CHAR: . = ] [ drop f ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: freebsd find-library*
|
||||
"l" prepend load-ldconfig-cache
|
||||
[ name-matches? ] with find nip ?first dup [ ".so" append ] when ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
freebsd
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: alien.libraries.finder sequences tools.test ;
|
||||
|
||||
{ t } [ "libm.so" "m" find-library subseq? ] unit-test
|
||||
{ t } [ "libc.so" "c" find-library subseq? ] unit-test
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
! Copyright (C) 2013 Björn Lindqvist, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
USING: alien.libraries.finder arrays assocs
|
||||
combinators.short-circuit io io.encodings.utf8 io.files
|
||||
io.files.info io.launcher kernel sequences sets splitting system
|
||||
unicode ;
|
||||
IN: alien.libraries.finder.linux
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: mach-map {
|
||||
{ ppc.64 { "libc6" "64bit" } }
|
||||
{ x86.32 { "libc6" "x32" } }
|
||||
{ x86.64 { "libc6" "x86-64" } }
|
||||
}
|
||||
|
||||
: parse-ldconfig-lines ( string -- triple )
|
||||
[
|
||||
"=>" split1 [ [ blank? ] trim ] bi@
|
||||
[
|
||||
" " split1 [ "()" in? ] trim "," split
|
||||
[ [ blank? ] trim ] map
|
||||
[ ": Linux" swap subseq? ] reject
|
||||
] dip 3array
|
||||
] map ;
|
||||
|
||||
: load-ldconfig-cache ( -- seq )
|
||||
"/sbin/ldconfig -p" utf8 [ lines ] with-process-reader
|
||||
rest parse-ldconfig-lines ;
|
||||
|
||||
: ldconfig-arch ( -- str )
|
||||
mach-map cpu of { "libc6" } or ;
|
||||
|
||||
: name-matches? ( lib triple -- ? )
|
||||
first swap ?head [ ?first CHAR: . = ] [ drop f ] if ;
|
||||
|
||||
: arch-matches? ( lib triple -- ? )
|
||||
[ drop ldconfig-arch ] [ second swap subset? ] bi* ;
|
||||
|
||||
: ldconfig-matches? ( lib triple -- ? )
|
||||
{ [ name-matches? ] [ arch-matches? ] } 2&& ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: linux find-library*
|
||||
"lib" prepend load-ldconfig-cache
|
||||
[ ldconfig-matches? ] with find nip ?last ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
linux
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
USING: alien.libraries.finder alien.libraries.finder.macosx
|
||||
alien.libraries.finder.macosx.private sequences tools.test ;
|
||||
|
||||
{
|
||||
{
|
||||
f
|
||||
f
|
||||
f
|
||||
f
|
||||
T{ framework-info f "Location" "Name.framework/Name" "Name" f f }
|
||||
T{ framework-info f "Location" "Name.framework/Name_suffix" "Name" f "suffix" }
|
||||
f
|
||||
f
|
||||
T{ framework-info f "Location" "Name.framework/Versions/A/Name" "Name" "A" f }
|
||||
T{ framework-info f "Location" "Name.framework/Versions/A/Name_suffix" "Name" "A" "suffix" }
|
||||
}
|
||||
} [
|
||||
{
|
||||
"broken/path"
|
||||
"broken/path/_suffix"
|
||||
"Location/Name.framework"
|
||||
"Location/Name.framework/_suffix"
|
||||
"Location/Name.framework/Name"
|
||||
"Location/Name.framework/Name_suffix"
|
||||
"Location/Name.framework/Versions"
|
||||
"Location/Name.framework/Versions/A"
|
||||
"Location/Name.framework/Versions/A/Name"
|
||||
"Location/Name.framework/Versions/A/Name_suffix"
|
||||
} [ make-framework-info ] map
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{
|
||||
"/usr/lib/libSystem.dylib"
|
||||
"/System/Library/Frameworks/System.framework/System"
|
||||
}
|
||||
} [
|
||||
{
|
||||
"libSystem.dylib"
|
||||
"System.framework/System"
|
||||
} [ dyld-find ] map
|
||||
] unit-test
|
||||
|
||||
{ t } [ "libm.dylib" "m" find-library subseq? ] unit-test
|
||||
{ t } [ "libc.dylib" "c" find-library subseq? ] unit-test
|
||||
{ t } [ "libbz2.dylib" "bz2" find-library subseq? ] unit-test
|
||||
{ t } [ "AGL.framework" "AGL" find-library subseq? ] unit-test
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
! Copyright (C) 2013 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors alien.libraries.finder arrays assocs
|
||||
combinators.short-circuit environment io.files io.files.info
|
||||
io.pathnames kernel locals make namespaces sequences splitting
|
||||
system ;
|
||||
|
||||
IN: alien.libraries.finder.macosx
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: framework-info location name shortname version suffix ;
|
||||
|
||||
: make-framework-info ( filename -- info/f )
|
||||
[ framework-info new ] dip
|
||||
"/" split dup [ ".framework" tail? ] find drop [
|
||||
cut [
|
||||
[ "/" join ] bi@ [ >>location ] [ >>name ] bi*
|
||||
] keep [
|
||||
rest dup ?first "Versions" = [
|
||||
rest dup empty? [
|
||||
unclip swap [ >>version ] dip
|
||||
] unless
|
||||
] when ?first "_" split1 [ >>shortname ] [ >>suffix ] bi*
|
||||
] unless-empty
|
||||
] [ drop ] if* dup shortname>> empty? [ drop f ] when ;
|
||||
|
||||
CONSTANT: default-framework-fallback {
|
||||
"~/Library/Frameworks"
|
||||
"/Library/Frameworks"
|
||||
"/Network/Library/Frameworks"
|
||||
"/System/Library/Frameworks"
|
||||
}
|
||||
|
||||
CONSTANT: default-library-fallback {
|
||||
"~/lib"
|
||||
"/usr/local/lib"
|
||||
"/lib"
|
||||
"/usr/lib"
|
||||
}
|
||||
|
||||
SYMBOL: dyld-environment
|
||||
|
||||
: dyld-env ( name -- seq )
|
||||
dyld-environment get [ at ] [ os-env ] if* ;
|
||||
|
||||
: dyld-paths ( name -- seq )
|
||||
dyld-env [ ":" split ] [ f ] if* ;
|
||||
|
||||
: paths% ( name seq -- )
|
||||
[ prepend-path , ] with each ;
|
||||
|
||||
: dyld-override-search ( name -- seq )
|
||||
[
|
||||
dup make-framework-info [
|
||||
name>> "DYLD_FRAMEWORK_PATH" dyld-paths paths%
|
||||
] when*
|
||||
|
||||
file-name "DYLD_LIBRARY_PATH" dyld-paths paths%
|
||||
] { } make ;
|
||||
|
||||
SYMBOL: dyld-executable-path
|
||||
|
||||
: dyld-executable-path-search ( name -- seq )
|
||||
"@executable_path/" ?head dyld-executable-path get and [
|
||||
dyld-executable-path get prepend-path
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
:: dyld-default-search ( name -- seq )
|
||||
name make-framework-info :> framework
|
||||
name file-name :> basename
|
||||
"DYLD_FALLBACK_FRAMEWORK_PATH" dyld-paths :> fallback-framework-path
|
||||
"DYLD_FALLBACK_LIBRARY_PATH" dyld-paths :> fallback-library-path
|
||||
[
|
||||
name ,
|
||||
|
||||
framework [
|
||||
name>> fallback-framework-path paths%
|
||||
] when*
|
||||
|
||||
basename fallback-library-path paths%
|
||||
|
||||
framework fallback-framework-path empty? and [
|
||||
framework name>> default-framework-fallback paths%
|
||||
] when
|
||||
|
||||
fallback-library-path empty? [
|
||||
basename default-library-fallback paths%
|
||||
] when
|
||||
] { } make ;
|
||||
|
||||
: dyld-image-suffix-search ( seq -- str )
|
||||
"DYLD_IMAGE_SUFFIX" dyld-env [
|
||||
swap [
|
||||
[
|
||||
[
|
||||
".dylib" ?tail [ prepend ] dip
|
||||
[ ".dylib" append ] when ,
|
||||
] [
|
||||
,
|
||||
] bi
|
||||
] with each
|
||||
] { } make
|
||||
] when* ;
|
||||
|
||||
: dyld-search-paths ( name -- paths )
|
||||
[ dyld-override-search ]
|
||||
[ dyld-executable-path-search ]
|
||||
[ dyld-default-search ] tri 3append
|
||||
dyld-image-suffix-search ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: dyld-find ( name -- path/f )
|
||||
dyld-search-paths
|
||||
[ { [ exists? ] [ file-info regular-file? ] } 1&& ] find
|
||||
[ nip ] when* ;
|
||||
|
||||
: framework-find ( name -- path )
|
||||
dup dyld-find [ nip ] [
|
||||
".framework" over subseq-start [
|
||||
dupd head
|
||||
] [
|
||||
[ ".framework" append ] keep
|
||||
] if* file-name append-path dyld-find
|
||||
] if* ;
|
||||
|
||||
M: macosx find-library*
|
||||
[ "lib" ".dylib" surround ]
|
||||
[ ".dylib" append ]
|
||||
[ ".framework/" over 3append ] tri 3array
|
||||
[ dyld-find ] map-find drop ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
macosx
|
||||
|
|
@ -0,0 +1 @@
|
|||
windows
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: alien.libraries.finder sequences tools.test ;
|
||||
|
||||
{ t } [ "kernel32.dll" "kernel32" find-library subseq? ] unit-test
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
! Copyright (C) 2013 Björn Lindqvist, John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: alien.libraries.finder arrays combinators.short-circuit
|
||||
environment io.backend io.files io.files.info io.pathnames kernel
|
||||
sequences splitting system system-info.windows ;
|
||||
|
||||
IN: alien.libraries.finder.windows
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: search-paths ( -- seq )
|
||||
"resource:" normalize-path
|
||||
system-directory
|
||||
windows-directory 3array
|
||||
"PATH" os-env [ ";" split ] [ f ] if* append ;
|
||||
|
||||
: candidate-paths ( name -- seq )
|
||||
search-paths over ".dll" tail? [
|
||||
[ prepend-path ] with map
|
||||
] [
|
||||
[
|
||||
[ prepend-path ]
|
||||
[ [ ".dll" append ] [ prepend-path ] bi* ] 2bi
|
||||
2array
|
||||
] with map concat
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: windows find-library*
|
||||
candidate-paths [
|
||||
{ [ exists? ] [ file-info regular-file? ] } 1&&
|
||||
] find nip ;
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax assocs help.markup help.syntax kernel
|
||||
strings ;
|
||||
IN: alien.libraries
|
||||
|
||||
HELP: add-library
|
||||
{ $values { "name" string } { "path" string } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } }
|
||||
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. You can find the location of the library via words in " { $vocab-link "alien.libraries.finder" } ". The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
|
||||
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
|
||||
$nl
|
||||
"This ensures that if the logical library is later used in the same file, for example by a " { $link POSTPONE: FUNCTION: } " definition. Otherwise, the " { $link add-library } " call will happen too late, after compilation, and the C function calls will not refer to the correct library."
|
||||
$nl
|
||||
"For details about parse-time evaluation, see " { $link "syntax-immediate" } "." }
|
||||
{ $examples "Here is a typical usage of " { $link add-library } ":"
|
||||
{ $code
|
||||
"<< \"sqlite\" \"sqlite3\" find-library cdecl add-library >>"
|
||||
}
|
||||
"You can also explicitly specify the library name by platform, if you prefer:"
|
||||
{ $code
|
||||
"<< \"freetype\" {"
|
||||
" { [ os macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
|
||||
" { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
|
||||
" [ drop ]"
|
||||
"} cond >>"
|
||||
}
|
||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||
|
||||
HELP: deploy-library
|
||||
{ $values { "name" string } }
|
||||
{ $description "Specifies that the logical library named " { $snippet "name" } " should be included during " { $link "tools.deploy" } ". " { $snippet "name" } " must be the name of a library previously loaded with " { $link add-library } "." } ;
|
||||
|
||||
HELP: dlclose
|
||||
{ $values { "dll" "a DLL handle" } }
|
||||
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
|
||||
|
||||
HELP: dlopen
|
||||
{ $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 add-library } ". Use the latter instead." } ;
|
||||
|
||||
HELP: dlsym
|
||||
{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" { $maybe alien } } }
|
||||
{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable. If the symbol was not found, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: dlsym?
|
||||
{ $values
|
||||
{ "function" string }
|
||||
{ "library" string }
|
||||
{ "alien/f" { $maybe alien } }
|
||||
}
|
||||
{ $description "Outputs the alien dynamically loaded with the given name in the given library. If no symbol is loaded, output f." } ;
|
||||
|
||||
HELP: make-library
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
|
||||
{ "library" library } }
|
||||
{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
|
||||
{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
|
||||
|
||||
HELP: libraries
|
||||
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
|
||||
|
||||
HELP: library
|
||||
{ $values { "name" string } { "library" assoc } }
|
||||
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||
{ $list
|
||||
{ { $snippet "name" } " - the full path of the C library binary" }
|
||||
{ { $snippet "abi" } " - the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
|
||||
{ { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: library-dll
|
||||
{ $values { "obj" object } { "dll" "a DLL handle" } }
|
||||
{ $description "Looks up a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." } ;
|
||||
|
||||
HELP: remove-library
|
||||
{ $values { "name" string } }
|
||||
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
|
||||
|
||||
ARTICLE: "loading-libs" "Loading native libraries"
|
||||
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
|
||||
{ $subsections
|
||||
add-library
|
||||
remove-library
|
||||
}
|
||||
"Once a library has been defined, you can see if the library has correctly loaded:"
|
||||
{ $subsections library-dll }
|
||||
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again."
|
||||
$nl
|
||||
"Libraries that do not come standard with the operating system need to be included with deployed applications that use them. A word is provided to instruct " { $link "tools.deploy" } " that a library must be so deployed:"
|
||||
{ $subsections
|
||||
deploy-library
|
||||
} ;
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
USING: accessors alien alien.libraries alien.syntax kernel tools.test ;
|
||||
IN: alien.libraries.tests
|
||||
|
||||
{ f } [ DLL" fadfasdfsada" dll-valid? ] unit-test
|
||||
|
||||
{ f } [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
|
||||
|
||||
{ } [ "doesnotexist" dlopen dlclose ] unit-test
|
||||
|
||||
[ "fdasfsf" dll-valid? drop ] must-fail
|
||||
|
||||
{ t } [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "BLAH" cdecl add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "blah" stdcall add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "blah" cdecl add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
||||
{ "blah" f } [
|
||||
"blah" cdecl make-library [ path>> ] [ dll>> dll-valid? ] bi
|
||||
] unit-test
|
||||
|
||||
! dlsym?
|
||||
{ t } [
|
||||
"err_no" "factor" dlsym? alien?
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.strings assocs compiler.errors
|
||||
io.backend kernel namespaces destructors sequences strings
|
||||
system io.pathnames fry combinators vocabs ;
|
||||
IN: alien.libraries
|
||||
|
||||
PRIMITIVE: dll-valid? ( dll -- ? )
|
||||
PRIMITIVE: (dlopen) ( path -- dll )
|
||||
PRIMITIVE: (dlsym) ( name dll -- alien )
|
||||
PRIMITIVE: dlclose ( dll -- )
|
||||
PRIMITIVE: (dlsym-raw) ( name dll -- alien )
|
||||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
||||
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
||||
|
||||
: dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
|
||||
|
||||
HOOK: dlerror os ( -- message/f )
|
||||
|
||||
SYMBOL: libraries
|
||||
|
||||
libraries [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: library { path string } dll dlerror { abi abi initial: cdecl } ;
|
||||
|
||||
C: <library> library
|
||||
|
||||
: lookup-library ( name -- library/f ) libraries get at ;
|
||||
|
||||
: open-dll ( path -- dll dll-error/f )
|
||||
[ dlopen dup dll-valid? [ f ] [ dlerror ] if ]
|
||||
[ f f ] if* ;
|
||||
|
||||
: make-library ( path abi -- library )
|
||||
[ dup open-dll ] dip <library> ;
|
||||
|
||||
GENERIC: library-dll ( obj -- dll )
|
||||
|
||||
M: f library-dll ;
|
||||
|
||||
M: library library-dll
|
||||
dup [ dll>> ] when ;
|
||||
|
||||
M: string library-dll ( library -- dll )
|
||||
lookup-library library-dll ;
|
||||
|
||||
: dlsym? ( function library -- alien/f )
|
||||
library-dll dlsym ;
|
||||
|
||||
M: dll dispose dlclose ;
|
||||
|
||||
M: library dispose dll>> [ dispose ] when* ;
|
||||
|
||||
: remove-library ( name -- )
|
||||
libraries get delete-at* [ dispose ] [ drop ] if ;
|
||||
|
||||
: same-library? ( library path abi -- ? )
|
||||
[ swap path>> = ] [ swap abi>> = ] bi-curry* bi and ;
|
||||
|
||||
: add-library? ( name path abi -- ? )
|
||||
[ lookup-library ] 2dip '[ _ _ same-library? not ] [ t ] if* ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
3dup add-library? [
|
||||
[ 2drop remove-library ]
|
||||
[ nipd make-library ]
|
||||
[ 2drop libraries get set-at ] 3tri
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: change-dll ( library path abi -- )
|
||||
swap >>abi
|
||||
swap >>path
|
||||
[ dispose ]
|
||||
[ path>> open-dll ]
|
||||
[ swap >>dlerror swap >>dll drop ] tri ;
|
||||
|
||||
: update-library ( name path abi -- )
|
||||
pick lookup-library [
|
||||
[ 2over same-library? not ] keep swap
|
||||
[ change-dll drop ] [ 4drop ] if
|
||||
] [
|
||||
make-library swap libraries get set-at
|
||||
] if* ;
|
||||
|
||||
: library-abi ( library -- abi )
|
||||
lookup-library [ abi>> ] [ cdecl ] if* ;
|
||||
|
||||
: address-of ( name library -- value )
|
||||
2dup library-dll dlsym-raw
|
||||
[ 2nip ] [ no-such-symbol ] if* ;
|
||||
|
||||
SYMBOL: deploy-libraries
|
||||
|
||||
deploy-libraries [ V{ } clone ] initialize
|
||||
|
||||
: deploy-library ( name -- )
|
||||
dup libraries get key?
|
||||
[ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
|
||||
[ "deploy-library failure" no-such-library ] if ;
|
||||
|
||||
HOOK: >deployed-library-path os ( path -- path' )
|
||||
|
||||
{
|
||||
{ [ os windows? ] [ "alien.libraries.windows" ] }
|
||||
{ [ os unix? ] [ "alien.libraries.unix" ] }
|
||||
} cond require
|
||||
|
|
@ -0,0 +1 @@
|
|||
unix
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
USING: alien.c-types alien.libraries alien io.encodings.utf8
|
||||
io.pathnames system ;
|
||||
IN: alien.libraries.unix
|
||||
|
||||
: (dlerror) ( -- string )
|
||||
\ c-string f "dlerror" { } f alien-invoke ; inline
|
||||
|
||||
M: unix dlerror (dlerror) ;
|
||||
|
||||
M: unix >deployed-library-path
|
||||
file-name "$ORIGIN" prepend-path ;
|
||||
|
||||
M: macosx >deployed-library-path
|
||||
file-name "@executable_path/../Frameworks" prepend-path ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
windows
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
USING: alien.libraries io.pathnames system windows.errors
|
||||
windows.kernel32 ;
|
||||
IN: alien.libraries.windows
|
||||
|
||||
M: windows >deployed-library-path
|
||||
file-name ;
|
||||
|
||||
M: windows dlerror ( -- message )
|
||||
GetLastError n>win32-error-string ;
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
||||
Joe Groff
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
! Copyright (C) 2009 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.parser alien.parser.private
|
||||
alien.syntax compiler.units continuations debugger eval fry kernel
|
||||
lexer namespaces parser sequences sets summary tools.test
|
||||
vocabs.parser words ;
|
||||
IN: alien.parser.tests
|
||||
|
||||
<<
|
||||
|
||||
: with-parsing ( lines quot -- )
|
||||
[ <lexer> ] [ '[ _ with-compilation-unit ] ] bi* with-lexer ; inline
|
||||
|
||||
! (CREATE-C-TYPE)
|
||||
{ "hello" } [
|
||||
{ "hello" } [ CREATE-C-TYPE name>> ] with-parsing
|
||||
] unit-test
|
||||
|
||||
! Check that it deletes from old-definitions
|
||||
{ 0 } [
|
||||
{ } [
|
||||
"hello" current-vocab create-word
|
||||
old-definitions get first adjoin
|
||||
"hello" (CREATE-C-TYPE) drop
|
||||
old-definitions get first cardinality
|
||||
] with-parsing
|
||||
] unit-test
|
||||
|
||||
! make-callback-type
|
||||
{ "what-type" } [
|
||||
{ } [
|
||||
void "what-type" f { } { } make-callback-type 2drop name>>
|
||||
] with-parsing
|
||||
] unit-test
|
||||
|
||||
{ 1 } [
|
||||
{ } [
|
||||
"hello" current-vocab create-word
|
||||
old-definitions get first adjoin
|
||||
void "hello" f { } { } make-callback-type 3drop
|
||||
old-definitions get first cardinality
|
||||
] with-parsing
|
||||
] unit-test
|
||||
|
||||
! parse-enum-name
|
||||
{ t } [
|
||||
{ "ayae" } [ parse-enum-name new-definitions get first in? ] with-parsing
|
||||
] unit-test
|
||||
|
||||
! validate-c-type-name
|
||||
{ "Cannot define a C type “hello*” that ends with an asterisk (*)" } [
|
||||
[ "hello*" validate-c-type-name ] [ ] recover summary
|
||||
] unit-test
|
||||
|
||||
>>
|
||||
|
||||
TYPEDEF: char char2
|
||||
|
||||
SYMBOL: not-c-type
|
||||
|
||||
CONSTANT: eleven 11
|
||||
|
||||
[
|
||||
"alien.parser.tests" use-vocab
|
||||
"alien.c-types" use-vocab
|
||||
|
||||
[ int ] [ "int" parse-c-type ] unit-test
|
||||
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
|
||||
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
|
||||
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
|
||||
[ pointer: void ] [ "void*" parse-c-type ] unit-test
|
||||
[ pointer: int ] [ "int*" parse-c-type ] unit-test
|
||||
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
|
||||
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
|
||||
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
|
||||
[ { pointer: int 3 } ] [ "int*[3]" parse-c-type ] unit-test
|
||||
[ { pointer: void 3 } ] [ "void*[3]" parse-c-type ] unit-test
|
||||
[ pointer: { int 3 } ] [ "int[3]*" parse-c-type ] unit-test
|
||||
[ c-string ] [ "c-string" parse-c-type ] unit-test
|
||||
[ char2 ] [ "char2" parse-c-type ] unit-test
|
||||
[ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
|
||||
|
||||
[ "void[3]" parse-c-type ] must-fail
|
||||
[ "int[3" parse-c-type ] must-fail
|
||||
[ "int[3][4" parse-c-type ] must-fail
|
||||
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
|
||||
] with-file-vocabs
|
||||
|
||||
FUNCTION: void* alien-parser-function-effect-test ( int *arg1, float arg2 )
|
||||
|
||||
{ ( arg1 arg2 -- void* ) } [
|
||||
\ alien-parser-function-effect-test "declared-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
{ t } [ \ alien-parser-function-effect-test inline? ] unit-test
|
||||
|
||||
FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-effect-test ( int *arg1, float arg2 )
|
||||
|
||||
{ ( arg1 arg2 -- void* ) } [
|
||||
\ (alien-parser-function-effect-test) "declared-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
{ t } [ \ (alien-parser-function-effect-test) inline? ] unit-test
|
||||
|
||||
CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 )
|
||||
|
||||
{ ( arg1 arg2 -- void* ) } [
|
||||
\ alien-parser-callback-effect-test "callback-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
{ t } [ \ alien-parser-callback-effect-test inline? ] unit-test
|
||||
|
||||
! Reported by mnestic
|
||||
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
|
||||
|
||||
{ "OK!" } [
|
||||
[
|
||||
"USE: specialized-arrays SPECIALIZED-ARRAY: alien-parser-test-int" eval( -- )
|
||||
! after restart, we end up here
|
||||
"OK!"
|
||||
] [ :1 ] recover
|
||||
] unit-test
|
||||
|
||||
! Redefinitions
|
||||
{ } [
|
||||
[ C-TYPE: hi TYPEDEF: void* hi ] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.enums alien.libraries
|
||||
arrays classes classes.parser combinators combinators.short-circuit
|
||||
compiler.units effects fry kernel lexer locals math namespaces parser
|
||||
sequences splitting summary vocabs.parser words ;
|
||||
IN: alien.parser
|
||||
|
||||
SYMBOL: current-library
|
||||
|
||||
DEFER: (parse-c-type)
|
||||
|
||||
ERROR: bad-array-type ;
|
||||
|
||||
: parse-array-type ( name -- c-type )
|
||||
"[" split unclip
|
||||
[ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ]
|
||||
[ (parse-c-type) ]
|
||||
bi* prefix ;
|
||||
|
||||
: (parse-c-type) ( string -- type )
|
||||
{
|
||||
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type ] }
|
||||
{ [ dup search ] [ parse-word ] }
|
||||
[ parse-word ]
|
||||
} cond ;
|
||||
|
||||
: c-array? ( c-type -- ? )
|
||||
{ [ array? ] [ first { [ c-type-word? ] [ pointer? ] } 1|| ] } 1&& ;
|
||||
|
||||
: valid-c-type? ( c-type -- ? )
|
||||
{ [ c-array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
|
||||
|
||||
: parse-c-type ( string -- type )
|
||||
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
||||
|
||||
: scan-c-type ( -- c-type )
|
||||
scan-token {
|
||||
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
|
||||
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
|
||||
[ parse-c-type ]
|
||||
} cond ;
|
||||
|
||||
: reset-c-type ( word -- )
|
||||
dup "struct-size" word-prop [
|
||||
dup [ forget-class ] [ "struct-size" remove-word-prop ] bi
|
||||
] when
|
||||
{
|
||||
"c-type"
|
||||
"callback-effect"
|
||||
"callback-library"
|
||||
} remove-word-props ;
|
||||
|
||||
ERROR: *-in-c-type-name name ;
|
||||
|
||||
M: *-in-c-type-name summary
|
||||
name>>
|
||||
"Cannot define a C type “"
|
||||
"” that ends with an asterisk (*)" surround ;
|
||||
|
||||
: validate-c-type-name ( name -- name )
|
||||
dup "*" tail?
|
||||
[ *-in-c-type-name ] when ;
|
||||
|
||||
: (CREATE-C-TYPE) ( name -- word )
|
||||
validate-c-type-name current-vocab create-word {
|
||||
[ fake-definition ]
|
||||
[ set-last-word ]
|
||||
[ reset-generic ]
|
||||
[ reset-c-type ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: CREATE-C-TYPE ( -- word )
|
||||
scan-token (CREATE-C-TYPE) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-pointers ( type name -- type' name' )
|
||||
"*" ?head
|
||||
[ [ <pointer> ] dip parse-pointers ] when ;
|
||||
|
||||
: next-enum-member ( members name value -- members value' )
|
||||
[ define-enum-value ]
|
||||
[ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ;
|
||||
|
||||
: parse-enum-name ( -- word )
|
||||
CREATE-C-TYPE dup save-location ;
|
||||
|
||||
: parse-enum-base-type ( -- base-type token )
|
||||
scan-token dup "<" =
|
||||
[ drop scan-object scan-token ]
|
||||
[ [ int ] dip ] if ;
|
||||
|
||||
: parse-enum-member ( members name value -- members value' )
|
||||
over "{" =
|
||||
[ 2drop scan-token create-class-in scan-object next-enum-member "}" expect ]
|
||||
[ [ create-class-in ] dip next-enum-member ] if ;
|
||||
|
||||
: parse-enum-members ( members counter token -- members )
|
||||
dup ";" = not
|
||||
[ swap parse-enum-member scan-token parse-enum-members ] [ 2drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: parse-enum ( -- name base-type members )
|
||||
parse-enum-name
|
||||
parse-enum-base-type
|
||||
[ V{ } clone 0 ] dip parse-enum-members ;
|
||||
|
||||
: scan-function-name ( -- return function )
|
||||
scan-c-type scan-token parse-pointers ;
|
||||
|
||||
:: scan-c-args ( -- types names )
|
||||
V{ } clone :> types
|
||||
V{ } clone :> names
|
||||
"(" expect scan-token [ dup ")" = ] [
|
||||
parse-c-type
|
||||
scan-token "," ?tail drop
|
||||
parse-pointers [ types push ] [ names push ] bi*
|
||||
scan-token
|
||||
] until drop types names [ >array ] bi@ ;
|
||||
|
||||
: function-effect ( names return -- effect )
|
||||
[ { } ] [ c-type-string 1array ] if-void <effect> ;
|
||||
|
||||
: create-function ( name -- word )
|
||||
create-word-in dup reset-generic ;
|
||||
|
||||
:: (make-function) ( return function library types names -- quot effect )
|
||||
return library function types '[ _ _ _ _ f alien-invoke ]
|
||||
names return function-effect ;
|
||||
|
||||
:: make-function ( return function library types names -- word quot effect )
|
||||
function create-function
|
||||
return function library types names (make-function) ;
|
||||
|
||||
: (FUNCTION:) ( -- return function library types names )
|
||||
scan-function-name current-library get scan-c-args ;
|
||||
|
||||
: callback-quot ( return types abi -- quot )
|
||||
'[ [ _ _ _ ] dip alien-callback ] ;
|
||||
|
||||
:: make-callback-type ( return function library types names -- word quot effect )
|
||||
function create-function :> type-word
|
||||
void* type-word typedef
|
||||
type-word names return function-effect "callback-effect" set-word-prop
|
||||
type-word library "callback-library" set-word-prop
|
||||
type-word return types library library-abi callback-quot ( quot -- alien ) ;
|
||||
|
||||
: (CALLBACK:) ( -- word quot effect )
|
||||
(FUNCTION:) make-callback-type ;
|
||||
|
||||
: global-quot ( type word -- quot )
|
||||
swap [ name>> current-library get ] dip
|
||||
'[ _ _ address-of 0 _ alien-value ] ;
|
||||
|
||||
: set-global-quot ( type word -- quot )
|
||||
swap [ name>> current-library get ] dip
|
||||
'[ _ _ address-of 0 _ set-alien-value ] ;
|
||||
|
||||
: define-global-getter ( type word -- )
|
||||
[ nip ] [ global-quot ] 2bi ( -- value ) define-declared ;
|
||||
|
||||
: define-global-setter ( type word -- )
|
||||
[ nip name>> "set-" prepend create-word-in ]
|
||||
[ set-global-quot ] 2bi ( obj -- ) define-declared ;
|
||||
|
||||
: define-global ( type word -- )
|
||||
[ define-global-getter ] [ define-global-setter ] 2bi ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Utilities used in implementation of alien parsing words
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: alien.prettyprint
|
||||
|
||||
HELP: alien-function-alias-word
|
||||
{ $class-description "Used to prettier pretty-printing of alien function words." } ;
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
USING: alien.c-types alien.syntax io.encodings.ascii
|
||||
io.streams.string prettyprint see tools.test ;
|
||||
IN: alien.prettyprint.tests
|
||||
|
||||
CONSTANT: FOO 10
|
||||
|
||||
FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w )
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
FUNCTION: int function_test
|
||||
( float x, int[4][FOO] y, char* z, ushort* w )
|
||||
" } [
|
||||
[ \ function_test see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
FUNCTION-ALIAS: function-test int function_test
|
||||
( float x, int[4][FOO] y, char* z, ushort *w )
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
FUNCTION-ALIAS: function-test int function_test
|
||||
( float x, int[4][FOO] y, char* z, ushort* w )
|
||||
" } [
|
||||
[ \ function-test see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
TYPEDEF: c-string[ascii] string-typedef
|
||||
TYPEDEF: char[1][2][3] array-typedef
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
TYPEDEF: c-string[ascii] string-typedef
|
||||
" } [
|
||||
[ \ string-typedef see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
TYPEDEF: char[1][2][3] array-typedef
|
||||
" } [
|
||||
[ \ array-typedef see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
C-TYPE: opaque-c-type
|
||||
|
||||
{ "USING: alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
C-TYPE: opaque-c-type
|
||||
" } [
|
||||
[ \ opaque-c-type see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
TYPEDEF: pointer: int pint
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
TYPEDEF: int* pint
|
||||
" } [
|
||||
[ \ pint see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
{ "pointer: int" } [ pointer: int unparse ] unit-test
|
||||
|
||||
CALLBACK: void callback-test ( int x, float[4] y )
|
||||
|
||||
{ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
CALLBACK: void callback-test ( int x, float[4] y )
|
||||
" } [
|
||||
[ \ callback-test see ] with-string-writer
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,138 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.enums alien.strings
|
||||
alien.syntax arrays assocs combinators combinators.short-circuit
|
||||
definitions effects kernel math.parser prettyprint.backend
|
||||
prettyprint.custom prettyprint.sections see see.private sequences
|
||||
words ;
|
||||
IN: alien.prettyprint
|
||||
|
||||
M: alien pprint*
|
||||
{
|
||||
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
|
||||
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
||||
[ \ ALIEN: [ alien-address >hex text ] pprint-prefix ]
|
||||
} cond ;
|
||||
|
||||
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
|
||||
|
||||
M: c-type-word definer drop \ C-TYPE: f ;
|
||||
M: c-type-word definition drop f ;
|
||||
M: c-type-word declarations. drop ;
|
||||
|
||||
<PRIVATE
|
||||
GENERIC: record-pointer ( pointer -- )
|
||||
M: object record-pointer drop ;
|
||||
M: word record-pointer record-vocab ;
|
||||
M: pointer record-pointer to>> record-pointer ;
|
||||
|
||||
GENERIC: record-c-type ( c-type -- )
|
||||
M: word record-c-type record-vocab ;
|
||||
M: pointer record-c-type record-pointer ;
|
||||
M: wrapper record-c-type wrapped>> record-c-type ;
|
||||
M: array record-c-type first record-c-type ;
|
||||
PRIVATE>
|
||||
|
||||
: pprint-c-type ( c-type -- )
|
||||
[ record-c-type ] [ c-type-string ] [ ] tri present-text ;
|
||||
|
||||
M: pointer pprint*
|
||||
<flow \ pointer: pprint-word to>> pprint* block> ;
|
||||
|
||||
M: typedef-word definer drop \ TYPEDEF: f ;
|
||||
|
||||
M: typedef-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ definer. ]
|
||||
[ "c-type" word-prop pprint-c-type ]
|
||||
[ pprint-word ]
|
||||
} cleave ;
|
||||
|
||||
: pprint-function-arg ( type name -- )
|
||||
[ pprint-c-type ] [ text ] bi* ;
|
||||
|
||||
: pprint-function-args ( types names -- )
|
||||
zip [ ] [
|
||||
unclip-last
|
||||
[ [ first2 "," append pprint-function-arg ] each ] dip
|
||||
first2 pprint-function-arg
|
||||
] if-empty ;
|
||||
|
||||
: pprint-library ( library -- )
|
||||
[ \ LIBRARY: [ text ] pprint-prefix ] when* ;
|
||||
|
||||
: pprint-function ( word quot -- )
|
||||
[ def>> first pprint-c-type ]
|
||||
swap
|
||||
[
|
||||
<block "(" text
|
||||
[ def>> fourth ] [ stack-effect in>> ] bi
|
||||
pprint-function-args
|
||||
")" text block>
|
||||
] tri ; inline
|
||||
|
||||
PREDICATE: alien-function-alias-word < word
|
||||
def>> {
|
||||
[ length 6 = ]
|
||||
[ last \ alien-invoke eq? ]
|
||||
} 1&& ;
|
||||
|
||||
M: alien-function-alias-word definer
|
||||
drop \ FUNCTION-ALIAS: f ;
|
||||
M: alien-function-alias-word definition drop f ;
|
||||
M: alien-function-alias-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ def>> second pprint-library ]
|
||||
[ definer. ]
|
||||
[ pprint-word ]
|
||||
[ [ def>> third text ] pprint-function ]
|
||||
} cleave ;
|
||||
M: alien-function-alias-word declarations. drop ;
|
||||
|
||||
PREDICATE: alien-function-word < alien-function-alias-word
|
||||
[ def>> third ] [ name>> ] bi = ;
|
||||
|
||||
M: alien-function-word definer
|
||||
drop \ FUNCTION: f ;
|
||||
M: alien-function-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ def>> second pprint-library ]
|
||||
[ definer. ]
|
||||
[ [ pprint-word ] pprint-function ]
|
||||
} cleave ;
|
||||
|
||||
PREDICATE: alien-callback-type-word < typedef-word
|
||||
"callback-effect" word-prop >boolean ;
|
||||
|
||||
M: alien-callback-type-word definer
|
||||
drop \ CALLBACK: f ;
|
||||
M: alien-callback-type-word definition drop f ;
|
||||
M: alien-callback-type-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ "callback-library" word-prop pprint-library ]
|
||||
[ definer. ]
|
||||
[ def>> first first pprint-c-type ]
|
||||
[ pprint-word ]
|
||||
[
|
||||
<block "(" text
|
||||
[ def>> first second ] [ "callback-effect" word-prop in>> ] bi
|
||||
pprint-function-args
|
||||
")" text block>
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
M: enum-c-type-word definer
|
||||
drop \ ENUM: \ ; ;
|
||||
M: enum-c-type-word synopsis*
|
||||
{
|
||||
[ seeing-word ]
|
||||
[ definer. ]
|
||||
[ pprint-word ]
|
||||
[ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
|
||||
} cleave ;
|
||||
M: enum-c-type-word definition
|
||||
lookup-c-type members>> ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Prettyprinting aliens and DLLs
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
USING: interpolate io io.encodings.ascii io.files io.files.temp
|
||||
io.launcher io.streams.string kernel locals sequences system ;
|
||||
IN: alien.remote-control.tests
|
||||
|
||||
: compile-file ( contents -- )
|
||||
"test.c" ascii set-file-contents
|
||||
{ "gcc" "-I../" "-L.." "-lfactor" "test.c" }
|
||||
os macosx? cpu x86.64? and [ "-m64" suffix ] when
|
||||
try-process ;
|
||||
|
||||
: run-test ( -- line )
|
||||
os windows? "a.exe" "a.out" ?
|
||||
ascii [ readln ] with-process-reader ;
|
||||
|
||||
:: test-embedding ( code -- line )
|
||||
image-path :> image
|
||||
|
||||
[
|
||||
[I
|
||||
#include <vm/master.h>
|
||||
#include <stdio.h>
|
||||
#include <stdbool.h>
|
||||
|
||||
int main(int argc, char **argv)
|
||||
{
|
||||
F_PARAMETERS p;
|
||||
default_parameters(&p);
|
||||
p.image_path = STRING_LITERAL("${image}");
|
||||
init_factor(&p);
|
||||
start_embedded_factor(&p);
|
||||
${code}
|
||||
printf("Done.\n");
|
||||
return 0;
|
||||
}
|
||||
I]
|
||||
] with-string-writer
|
||||
[ compile-file ] with-temp-directory
|
||||
[ run-test ] with-temp-directory ;
|
||||
|
||||
! [ "Done." ] [ "" test-embedding ] unit-test
|
||||
|
||||
! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.data eval io.encodings.utf8
|
||||
kernel kernel.private threads words ;
|
||||
IN: alien.remote-control
|
||||
|
||||
: eval-callback ( -- callback )
|
||||
void* { c-string } cdecl
|
||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||
|
||||
: yield-callback ( -- callback )
|
||||
void { } cdecl [ yield ] alien-callback ;
|
||||
|
||||
: sleep-callback ( -- callback )
|
||||
void { long } cdecl [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup word-optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
||||
: init-remote-control ( -- )
|
||||
\ eval-callback ?callback OBJ-EVAL-CALLBACK set-special-object
|
||||
\ yield-callback ?callback OBJ-YIELD-CALLBACK set-special-object
|
||||
\ sleep-callback ?callback OBJ-SLEEP-CALLBACK set-special-object ;
|
||||
|
||||
MAIN: init-remote-control
|
||||
|
|
@ -0,0 +1 @@
|
|||
Support for embedding Factor in other applications
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
C library interface parsing words
|
||||
|
|
@ -0,0 +1,136 @@
|
|||
IN: alien.syntax
|
||||
USING: alien alien.c-types alien.enums alien.libraries classes.struct
|
||||
help.markup help.syntax see ;
|
||||
|
||||
HELP: DLL"
|
||||
{ $syntax "DLL\" path\"" }
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Constructs a DLL handle at parse time." } ;
|
||||
|
||||
HELP: ALIEN:
|
||||
{ $syntax "ALIEN: address" }
|
||||
{ $values { "address" "a non-negative hexadecimal integer" } }
|
||||
{ $description "Creates an alien object at parse time." }
|
||||
{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
|
||||
|
||||
ARTICLE: "syntax-aliens" "Alien object literal syntax"
|
||||
{ $subsections
|
||||
POSTPONE: ALIEN:
|
||||
POSTPONE: DLL"
|
||||
} ;
|
||||
|
||||
HELP: LIBRARY:
|
||||
{ $syntax "LIBRARY: name" }
|
||||
{ $values { "name" "a logical library name" } }
|
||||
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: C-GLOBAL: } " and " { $link POSTPONE: CALLBACK: } " definitions, as well as " { $link POSTPONE: &: } " forms." }
|
||||
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
|
||||
|
||||
HELP: FUNCTION:
|
||||
{ $syntax "FUNCTION: return name ( parameters )" }
|
||||
{ $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
|
||||
{ $description "Defines a new word " { $snippet "name" } " which calls the C library function with the same " { $snippet "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 ( c-string question, int value )"
|
||||
"\"the question\" 42 the_answer"
|
||||
"The answer to the question is 42."
|
||||
} }
|
||||
"Using the " { $link c-string } " type instead of " { $snippet "char*" } " causes the FFI to automatically convert Factor strings to C strings. See " { $link "c-strings" } " for more information on using strings with the FFI."
|
||||
{ $notes "To make a Factor word with a name different from the C function, use " { $link POSTPONE: FUNCTION-ALIAS: } "." } ;
|
||||
|
||||
HELP: FUNCTION-ALIAS:
|
||||
{ $syntax "FUNCTION-ALIAS: factor-name
|
||||
return c_name ( parameters ) ;" }
|
||||
{ $values { "factor-name" "a Factor word name" } { "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 "factor-name" } " which calls the C library function named " { $snippet "c_name" } " in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
|
||||
$nl
|
||||
"The new word must be compiled before being executed." }
|
||||
{ $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 easier to read." } ;
|
||||
|
||||
{ POSTPONE: FUNCTION: POSTPONE: FUNCTION-ALIAS: } related-words
|
||||
|
||||
HELP: TYPEDEF:
|
||||
{ $syntax "TYPEDEF: old new" }
|
||||
{ $values { "old" "a C type" } { "new" "a C type" } }
|
||||
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||
{ $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: ENUM:
|
||||
{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
|
||||
{ $values { "type" { $maybe "a name to typedef to int" } } { "words" "a sequence of word names" } }
|
||||
{ $description "Creates a c-type that boxes and unboxes integer values to symbols. A symbol is defined for each member word. The base c-type can optionally be specified and defaults to " { $link int } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
|
||||
{ $examples
|
||||
"Here is an example enumeration definition:"
|
||||
{ $code "ENUM: color_t red { green 3 } blue ;" }
|
||||
"The following expression returns true:"
|
||||
{ $code "3 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
|
||||
|
||||
"Here is a version where the C-type takes a single byte:"
|
||||
{ $code "ENUM: tv_peripherals_1 < uchar\n{ appletv 1 } { chromecast 2 } { roku 4 } ;" }
|
||||
|
||||
"The same as above but four bytes instead of one:"
|
||||
{ $code "ENUM: tv_peripherals_4 < uint\n{ appletv 1 } { chromecast 2 } { roku 4 } ;" }
|
||||
} ;
|
||||
|
||||
HELP: C-TYPE:
|
||||
{ $syntax "C-TYPE: type" }
|
||||
{ $values { "type" "a new C type" } }
|
||||
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "." $nl
|
||||
{ $snippet "C-TYPE:" } " can also be used to forward declare C types, allowing circular dependencies to occur between types. For example:"
|
||||
{ $code "C-TYPE: forward
|
||||
STRUCT: backward { x forward* } ;
|
||||
STRUCT: forward { x backward* } ;" } }
|
||||
{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
|
||||
|
||||
HELP: CALLBACK:
|
||||
{ $syntax "CALLBACK: return type ( parameters )" }
|
||||
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
|
||||
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"CALLBACK: bool FakeCallback ( int message, void* payload )"
|
||||
": MyFakeCallback ( -- alien )"
|
||||
" [| message payload |"
|
||||
" \"message #\" write"
|
||||
" message number>string write"
|
||||
" \" received\" write nl"
|
||||
" t"
|
||||
" ] FakeCallback ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: &:
|
||||
{ $syntax "&: symbol" }
|
||||
{ $values { "symbol" "A C global variable name" } }
|
||||
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||
|
||||
HELP: typedef
|
||||
{ $values { "old" "a C type" } { "new" "a C type" } }
|
||||
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
|
||||
|
||||
{ POSTPONE: TYPEDEF: typedef } related-words
|
||||
|
||||
HELP: C-GLOBAL:
|
||||
{ $syntax "C-GLOBAL: type name" }
|
||||
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
|
||||
{ $description "Defines a getter " { $snippet "name" } " and setter " { $snippet "set-name" } " for the global value in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||
|
||||
ARTICLE: "alien.enums" "Enumeration types"
|
||||
"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum singletons and integers. It is possible to dispatch off of members of an enum."
|
||||
$nl
|
||||
"Defining enums:"
|
||||
{ $subsection POSTPONE: ENUM: }
|
||||
"Defining enums at run-time:"
|
||||
{ $subsection define-enum }
|
||||
"Conversions between enums and integers:"
|
||||
{ $subsections enum>number number>enum } ;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.enums alien.libraries
|
||||
alien.parser fry kernel lexer namespaces parser sequences
|
||||
strings.parser vocabs words ;
|
||||
<< "alien.arrays" require >> ! needed for bootstrap
|
||||
IN: alien.syntax
|
||||
|
||||
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
|
||||
|
||||
SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
|
||||
|
||||
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
|
||||
|
||||
SYNTAX: LIBRARY: scan-token current-library set ;
|
||||
|
||||
SYNTAX: FUNCTION:
|
||||
(FUNCTION:) make-function define-inline ;
|
||||
|
||||
SYNTAX: FUNCTION-ALIAS:
|
||||
scan-token create-function
|
||||
(FUNCTION:) (make-function) define-inline ;
|
||||
|
||||
SYNTAX: CALLBACK:
|
||||
(CALLBACK:) define-inline ;
|
||||
|
||||
SYNTAX: TYPEDEF:
|
||||
scan-c-type CREATE-C-TYPE dup save-location typedef ;
|
||||
|
||||
SYNTAX: ENUM:
|
||||
parse-enum (define-enum) ;
|
||||
|
||||
SYNTAX: C-TYPE:
|
||||
void CREATE-C-TYPE typedef ;
|
||||
|
||||
SYNTAX: &:
|
||||
scan-token current-library get '[ _ _ address-of ] append! ;
|
||||
|
||||
SYNTAX: C-GLOBAL: scan-c-type scan-new-word define-global ;
|
||||
|
||||
SYNTAX: pointer:
|
||||
scan-c-type <pointer> suffix! ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
USING: help.markup help.syntax kernel strings ;
|
||||
IN: ascii
|
||||
|
||||
HELP: blank?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for an ASCII whitespace character." } ;
|
||||
|
||||
HELP: letter?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for a lowercase alphabet ASCII character." } ;
|
||||
|
||||
HELP: LETTER?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for a uppercase alphabet ASCII character." } ;
|
||||
|
||||
HELP: digit?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for an ASCII decimal digit character." } ;
|
||||
|
||||
HELP: Letter?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
|
||||
|
||||
HELP: alpha?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for an alphanumeric ASCII character." } ;
|
||||
|
||||
HELP: printable?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for a printable ASCII character." } ;
|
||||
|
||||
HELP: control?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for an ASCII control character." } ;
|
||||
|
||||
HELP: quotable?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
|
||||
|
||||
HELP: ascii?
|
||||
{ $values { "ch" "a character" } { "?" boolean } }
|
||||
{ $description "Tests for whether a number is an ASCII character." } ;
|
||||
|
||||
HELP: ch>lower
|
||||
{ $values { "ch" "a character" } { "lower" "a character" } }
|
||||
{ $description "Converts an ASCII character to lower case." } ;
|
||||
|
||||
HELP: ch>upper
|
||||
{ $values { "ch" "a character" } { "upper" "a character" } }
|
||||
{ $description "Converts an ASCII character to upper case." } ;
|
||||
|
||||
HELP: >lower
|
||||
{ $values { "str" string } { "lower" string } }
|
||||
{ $description "Converts an ASCII string to lower case." } ;
|
||||
|
||||
HELP: >upper
|
||||
{ $values { "str" string } { "upper" string } }
|
||||
{ $description "Converts an ASCII string to upper case." } ;
|
||||
|
||||
HELP: >title
|
||||
{ $values { "str" string } { "title" string } }
|
||||
{ $description "Converts a string to title case." } ;
|
||||
|
||||
HELP: >words
|
||||
{ $values { "str" string } { "words" "an array of slices" } }
|
||||
{ $description "Divides the string up into words." } ;
|
||||
|
||||
HELP: capitalize
|
||||
{ $values { "str" string } { "str'" string } }
|
||||
{ $description "Capitalize all the words in a string." } ;
|
||||
|
||||
ARTICLE: "ascii" "ASCII"
|
||||
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
|
||||
$nl
|
||||
"ASCII character classes:"
|
||||
{ $subsections
|
||||
blank?
|
||||
letter?
|
||||
LETTER?
|
||||
digit?
|
||||
printable?
|
||||
control?
|
||||
quotable?
|
||||
ascii?
|
||||
}
|
||||
"ASCII case conversion:"
|
||||
{ $subsections
|
||||
ch>lower
|
||||
ch>upper
|
||||
>lower
|
||||
>upper
|
||||
>title
|
||||
} ;
|
||||
|
||||
ABOUT: "ascii"
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
USING: ascii kernel math sequences strings tools.test ;
|
||||
|
||||
{ t } [ CHAR: a letter? ] unit-test
|
||||
{ f } [ CHAR: A letter? ] unit-test
|
||||
{ f } [ CHAR: a LETTER? ] unit-test
|
||||
{ t } [ CHAR: A LETTER? ] unit-test
|
||||
{ t } [ CHAR: 0 digit? ] unit-test
|
||||
{ f } [ CHAR: x digit? ] unit-test
|
||||
|
||||
{ 4 } [
|
||||
0 "There are Four Upper Case characters"
|
||||
[ LETTER? [ 1 + ] when ] each
|
||||
] unit-test
|
||||
|
||||
{ t f } [ CHAR: \s ascii? 400 ascii? ] unit-test
|
||||
|
||||
{ "HELLO HOW ARE YOU?" } [ "hellO hOw arE YOU?" >upper ] unit-test
|
||||
{ "i'm good thx bai" } [ "I'm Good THX bai" >lower ] unit-test
|
||||
|
||||
{ "Hello How Are You?" } [ "hEllo how ARE yOU?" >title ] unit-test
|
||||
{ { " " "Hello" " " " " " " "World" } } [ " Hello World" >words [ >string ] map ] unit-test
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit hints kernel math math.order
|
||||
sequences strings ;
|
||||
IN: ascii
|
||||
|
||||
: ascii? ( ch -- ? ) 0 127 between? ; inline
|
||||
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
|
||||
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
|
||||
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
|
||||
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
|
||||
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
|
||||
: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline
|
||||
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
|
||||
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
|
||||
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
|
||||
: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline
|
||||
: >lower ( str -- lower ) [ ch>lower ] map ;
|
||||
: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline
|
||||
: >upper ( str -- upper ) [ ch>upper ] map ;
|
||||
: >words ( str -- words )
|
||||
[ dup empty? not ] [
|
||||
dup [ blank? ] find drop
|
||||
[ [ 1 ] when-zero cut-slice swap ]
|
||||
[ f 0 rot [ length ] keep <slice> ] if*
|
||||
] produce nip ;
|
||||
: capitalize ( str -- str' ) >lower 0 over [ ch>upper ] change-nth ;
|
||||
: >title ( str -- title ) >words [ capitalize ] map concat ;
|
||||
|
||||
HINTS: >lower string ;
|
||||
HINTS: >upper string ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
ASCII character classes
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue