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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2010-06-03 14:52:32 -05:00
parent e5ed53303d 063c9783fb
commit 3ef4c174d3
1428 changed files with 130563 additions and 17701 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -12,6 +12,7 @@ Factor/factor
*.res
*.RES
*.image
factor.image.fresh
*.dylib
factor
factor.com

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

@ -32,7 +32,7 @@
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>CFBundleVersion</key>
<string>0.93</string>
<string>0.94</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2010 Factor developers</string>
<key>NSServices</key>

59
GNUmakefile
View File

@ -4,7 +4,7 @@ ifdef CONFIG
AR = ar
LD = ld
VERSION = 0.93
VERSION = 0.94
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
@ -52,6 +52,7 @@ ifdef CONFIG
vm/io.o \
vm/jit.o \
vm/math.o \
vm/mvm.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
@ -105,61 +106,63 @@ help:
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
ALL = factor factor-ffi-test factor-lib
openbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
@ -168,22 +171,18 @@ macosx.app: factor
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor-lib: $(ENGINE)
factor: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
factor-console: $(EXE_OBJS) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
@ -222,4 +221,4 @@ clean:
tags:
etags vm/*.{cpp,hpp,mm,S,c}
.PHONY: factor factor-console factor-ffi-test tags clean macosx.app
.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app

76
Nmakefile
View File

@ -1,15 +1,31 @@
!IF DEFINED(DEBUG)
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3
!IF !DEFINED(BOOTIMAGE_VERSION)
BOOTIMAGE_VERSION = latest
!ENDIF
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
!IF DEFINED(PLATFORM)
DLL_OBJS = vm\os-windows-nt.obj \
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3 /D_CRT_SECURE_NO_WARNINGS
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
!ENDIF
!IF "$(PLATFORM)" == "x86-32"
LINK_FLAGS = $(LINK_FLAGS) /safeseh
PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
!ELSEIF "$(PLATFORM)" == "x86-64"
PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
!ENDIF
ML_FLAGS = /nologo /safeseh
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\os-windows.obj \
vm\os-windows-nt.obj \
vm\aging_collector.obj \
vm\alien.obj \
vm\arrays.obj \
@ -38,6 +54,8 @@ DLL_OBJS = vm\os-windows-nt.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
vm\mvm.obj \
vm\mvm-windows-nt.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
@ -58,31 +76,49 @@ DLL_OBJS = vm\os-windows-nt.obj \
.c.obj:
cl $(CL_FLAGS) /Fo$@ /c $<
.asm.obj:
ml $(ML_FLAGS) /Fo$@ /c $<
.rs.res:
rc $<
all: factor.com factor.exe libfactor-ffi-test.dll
libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.com: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
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
@exit 1
x86-32:
nmake /nologo PLATFORM=x86-32 /f Nmakefile all
x86-64:
nmake /nologo PLATFORM=x86-64 /f Nmakefile all
clean:
del vm\*.obj
del factor.lib
del factor.com
del factor.exe
del factor.dll
del factor.dll.lib
if exist factor.lib del factor.lib
if exist factor.com del factor.com
if exist factor.exe del factor.exe
if exist factor.dll del factor.dll
if exist factor.dll.lib del factor.dll.lib
.PHONY: all clean
.PHONY: all default x86-32 x86-64 clean
.SUFFIXES: .rs

91
basis/alarms/alarms-docs.factor
View File

@ -2,46 +2,49 @@ USING: help.markup help.syntax calendar quotations system ;
IN: alarms
HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;
HELP: current-alarm
{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
}
{ $examples
{ $unchecked-example
"""USING: alarms calendar io threads ;"""
"""["""
""" "Hi, this should only get printed once..." print flush"""
""" current-alarm get cancel-alarm"""
"""] 1 seconds every"""
""
}
} ;
HELP: add-alarm
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
HELP: later
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes drop"""
""
}
} ;
HELP: cancel-alarm
HELP: start-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
{ $description "Starts an alarm." } ;
HELP: restart-alarm
{ $values { "alarm" alarm } }
{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;
HELP: stop-alarm
{ $values { "alarm" alarm } }
{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
HELP: every
{ $values
{ "quot" quotation } { "interval-duration" duration }
{ "alarm" alarm } }
{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
""
}
} ;
HELP: later
{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }
{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes later drop"""
""
}
} ;
HELP: delayed-every
{ $values
{ "quot" quotation } { "duration" duration }
{ "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
@ -51,19 +54,21 @@ HELP: every
} ;
ARTICLE: "alarms" "Alarms"
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $nl
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl
"The alarm class:"
{ $subsections alarm }
"Register a recurring alarm:"
"Create an alarm before starting it:"
{ $subsections <alarm> }
"Starting an alarm:"
{ $subsections start-alarm restart-alarm }
"Stopping an alarm:"
{ $subsections stop-alarm }
"A recurring alarm without an initial delay:"
{ $subsections every }
"Register a one-time alarm:"
"A one-time alarm with an initial delay:"
{ $subsections later }
"The currently executing alarm:"
{ $subsections current-alarm }
"Low-level interface to add alarms:"
{ $subsections add-alarm }
"Cancelling an alarm:"
{ $subsections cancel-alarm }
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
"A recurring alarm with an initial delay:"
{ $subsections delayed-every } ;
ABOUT: "alarms"

62
basis/alarms/alarms-tests.factor
View File

@ -1,17 +1,67 @@
USING: alarms alarms.private kernel calendar sequences
tools.test threads concurrency.count-downs ;
USING: alarms alarms.private calendar concurrency.count-downs
concurrency.promises fry kernel math math.order sequences
threads tools.test tools.time ;
IN: alarms.tests
[ ] [
1 <count-down>
{ f } clone 2dup
[ first cancel-alarm count-down ] 2curry 1 seconds later
[ first stop-alarm count-down ] 2curry 1 seconds later
swap set-first
await
] unit-test
[ ] [
[
[ resume ] curry instant later drop
] "test" suspend drop
self [ resume ] curry instant later drop
"test" suspend drop
] unit-test
[ t ] [
[
<promise>
[ '[ t _ fulfill ] 2 seconds later drop ]
[ 5 seconds ?promise-timeout drop ] bi
] benchmark 1,500,000,000 2,500,000,000 between?
] unit-test
[ { 3 } ] [
{ 3 } dup
'[ 4 _ set-first ] 2 seconds later
1/2 seconds sleep
stop-alarm
] unit-test
[ { 1 } ] [
{ 0 }
dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later
[ stop-alarm ] [ start-alarm ] bi
4 seconds sleep
] unit-test
[ { 0 } ] [
{ 0 }
dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later
2 seconds sleep stop-alarm
1/2 seconds sleep
] unit-test
[ { 0 } ] [
{ 0 }
dup '[ 1 _ set-first ] 300 milliseconds later
150 milliseconds sleep
[ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi
] unit-test
[ { 1 } ] [
{ 0 }
dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
100 milliseconds sleep restart-alarm 300 milliseconds sleep
] unit-test
[ { 4 } ] [
{ 0 }
dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds
<alarm> dup start-alarm
700 milliseconds sleep dup restart-alarm
700 milliseconds sleep stop-alarm 500 milliseconds sleep
] unit-test

167
basis/alarms/alarms.factor
View File

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

75
basis/alien/arrays/arrays.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.data alien.accessors
USING: alien alien.strings alien.c-types alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
io.encodings.binary io.encodings.utf8 accessors compiler.units ;
IN: alien.arrays
INSTANCE: array value-type
@ -22,28 +22,10 @@ M: array c-type-align first c-type-align ;
M: array c-type-align-first first c-type-align-first ;
M: array c-type-stack-align? drop f ;
M: array unbox-parameter drop void* unbox-parameter ;
M: array unbox-return drop void* unbox-return ;
M: array box-parameter drop void* box-parameter ;
M: array box-return drop void* box-return ;
M: array stack-size drop void* stack-size ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: array base-type drop void* base-type ;
PREDICATE: string-type < pair
first2 [ char* = ] [ word? ] bi* and ;
first2 [ c-string = ] [ word? ] bi* and ;
M: string-type c-type ;
@ -51,47 +33,25 @@ 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 heap-size drop void* heap-size ;
M: string-type c-type-align
drop void* c-type-align ;
M: string-type c-type-align drop void* c-type-align ;
M: string-type c-type-align-first
drop void* c-type-align-first ;
M: string-type c-type-align-first drop void* c-type-align-first ;
M: string-type c-type-stack-align?
drop void* c-type-stack-align? ;
M: string-type base-type drop void* base-type ;
M: string-type unbox-parameter
drop void* unbox-parameter ;
M: string-type unbox-return
drop void* unbox-return ;
M: string-type box-parameter
drop void* box-parameter ;
M: string-type box-return
drop void* box-return ;
M: string-type stack-size
drop void* stack-size ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
drop void* c-type-boxer ;
M: string-type c-type-unboxer
drop void* c-type-unboxer ;
M: string-type c-type-rep drop int-rep ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
second dup binary =
[ drop void* c-type-boxer-quot ]
[ '[ _ alien>string ] ] if ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
second dup binary =
[ drop void* c-type-unboxer-quot ]
[ '[ _ string>alien ] ] if ;
M: string-type c-type-getter
drop [ alien-cell ] ;
@ -99,8 +59,5 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ char* utf8 } char* typedef
char* uchar* typedef
[ { c-string utf8 } c-string typedef ] with-compilation-unit
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

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

@ -1,66 +1,42 @@
USING: alien alien.complex help.syntax help.markup libc kernel.private
byte-arrays strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
classes.struct math kernel ;
QUALIFIED: math
QUALIFIED: sequences
IN: alien.c-types
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
HELP: heap-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $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: stack-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
{ $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
HELP: no-c-type
{ $values { "name" "a C type name" } }
{ $values { "name" c-type-name } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
HELP: c-type
{ $values { "name" "a C type" } { "c-type" 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: c-getter
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
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: c-setter
{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: box-parameter
{ $values { "n" math:integer } { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: box-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
HELP: unbox-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: 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: define-deref
{ $values { "c-type" "a C type" } }
@ -103,8 +79,8 @@ HELP: ulonglong
HELP: void
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a 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." } ;
@ -115,6 +91,19 @@ HELP: complex-float
HELP: complex-double
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
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." { $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 } 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."
@ -191,11 +180,11 @@ ARTICLE: "c-types.primitives" "Primitive C types"
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
ARTICLE: "c-types.pointers" "Pointer and array types"
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
"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 and thus the dimensions only serve as documentation." ;
"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:"
@ -228,7 +217,7 @@ ARTICLE: "c-types.structs" "Struct and union types"
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
ARTICLE: "c-types-specs" "C type specifiers"
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
"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

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

@ -1,6 +1,6 @@
USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct classes
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
IN: alien.c-types.tests
@ -16,36 +16,39 @@ UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ pointer: void c-type void* c-type = ] unit-test
[ t ] [ pointer: int c-type void* c-type = ] unit-test
[ t ] [ pointer: int* c-type void* c-type = ] unit-test
[ f ] [ pointer: foo c-type void* c-type = ] unit-test
[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
[ t ] [ c-string c-type c-string c-type = ] unit-test
[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ int c-type MyInt c-type = ] unit-test
[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
TYPEDEF: char MyChar
[ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
TYPEDEF: { c-string ascii } MyFunkyString
[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test
TYPEDEF: c-string MyString
[ t ] [ c-string c-type MyString c-type = ] unit-test
[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
TYPEDEF: int* MyIntArray
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
@ -63,7 +66,7 @@ os windows? cpu x86.64? and [
C-TYPE: opaque
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
[ opaque c-type ] [ no-c-type? ] must-fail-with
[ """

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

@ -1,12 +1,12 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private math
USING: byte-arrays arrays assocs delegate kernel kernel.private math
math.order math.parser namespaces make parser sequences strings
words splitting cpu.architecture alien alien.accessors
alien.strings quotations layouts system compiler.units io
io.files io.encodings.binary io.streams.memory accessors
combinators effects continuations fry classes vocabs
vocabs.loader words.symbol ;
vocabs.loader words.symbol macros ;
QUALIFIED: math
IN: alien.c-types
@ -38,32 +38,24 @@ TUPLE: abstract-c-type
TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align? ;
{ rep initial: int-rep } ;
: <c-type> ( -- c-type )
\ c-type new ; inline
ERROR: no-c-type name ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
UNION: c-type-name string c-type-word ;
! C type protocol
GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
PREDICATE: c-type-word < word
"c-type" word-prop ;
<< \ void \ void* "pointer-c-type" set-word-prop >>
TUPLE: pointer { to initial: void read-only } ;
C: <pointer> pointer
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
M: array resolve-pointer-type
first resolve-pointer-type ;
UNION: c-type-name
c-type-word pointer ;
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
@ -73,178 +65,96 @@ M: word c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
GENERIC: c-struct? ( c-type -- ? )
M: object c-struct? drop f ;
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: c-type-name c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
M: c-type-name c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
M: c-type-name c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
M: c-type-name c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
M: c-type-name c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
M: c-type-name c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
GENERIC: c-type-align ( name -- n ) foldable
M: abstract-c-type c-type-align align>> ;
M: c-type-name c-type-align c-type c-type-align ;
GENERIC: c-type-align-first ( name -- n )
M: c-type-name c-type-align-first c-type c-type-align-first ;
M: abstract-c-type c-type-align-first align-first>> ;
GENERIC: c-type-stack-align? ( name -- ? )
GENERIC: base-type ( c-type -- c-type )
M: c-type c-type-stack-align? stack-align?>> ;
M: c-type-name base-type c-type ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
: c-type-unbox ( n c-type -- )
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
M: c-type-name box-parameter c-type box-parameter ;
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
M: c-type-name box-return c-type box-return ;
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
M: c-type-name unbox-return c-type unbox-return ;
M: c-type base-type ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size )
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
M: c-type-name stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
MIXIN: value-type
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
] unless* ;
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
bi append ;
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
[ swapd heap-size * >fixnum ] keep ; inline
: array-accessor ( c-type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
: alien-element ( n c-ptr c-type -- value )
array-accessor alien-value ; inline
GENERIC: typedef ( old new -- )
: 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-setter
c-type-align
c-type-align-first
base-type
heap-size ;
CONSULT: c-type-protocol c-type-name
c-type ;
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
M: word typedef ( old new -- )
: typedef ( old new -- )
{
[ nip define-symbol ]
[ swap "c-type" set-word-prop ]
[
swap dup c-type-name? [
resolve-pointer-type
"pointer-c-type" set-word-prop
] [ 2drop ] if
]
} 2cleave ;
TUPLE: long-long-type < c-type ;
@ -252,25 +162,14 @@ TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- c-type )
long-long-type new ;
M: long-long-type unbox-parameter ( n c-type -- )
c-type-unboxer %unbox-long-long ;
M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
M: long-long-type box-parameter ( n c-type -- )
c-type-boxer %box-long-long ;
M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
: define-deref ( c-type -- )
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
[ name>> CHAR: * prefix "alien.c-types" create ]
[ '[ 0 _ alien-value ] ]
bi (( c-ptr -- value )) define-inline ;
: define-out ( c-type -- )
[ name>> "alien.c-types" constructor-word ]
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
[ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
@ -279,6 +178,10 @@ M: long-long-type box-return ( c-type -- )
: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
c-string ;
CONSTANT: primitive-types
{
char uchar
@ -288,11 +191,14 @@ CONSTANT: primitive-types
longlong ulonglong
float double
void* bool
c-string
}
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
<PRIVATE
: 8-byte-alignment ( c-type -- c-type )
{
@ -301,12 +207,32 @@ SYMBOLS:
[ 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 c-type
[ \ void* 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
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
@ -315,30 +241,6 @@ SYMBOLS:
"alien_offset" >>unboxer
\ void* define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
@ -349,6 +251,7 @@ SYMBOLS:
2 >>align-first
"from_signed_2" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ short define-primitive-type
<c-type>
@ -361,6 +264,7 @@ SYMBOLS:
2 >>align-first
"from_unsigned_2" >>boxer
"to_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ ushort define-primitive-type
<c-type>
@ -373,6 +277,7 @@ SYMBOLS:
1 >>align-first
"from_signed_1" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ char define-primitive-type
<c-type>
@ -385,34 +290,14 @@ SYMBOLS:
1 >>align-first
"from_unsigned_1" >>boxer
"to_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uchar define-primitive-type
cpu ppc? [
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] [
<c-type>
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
1 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] if
\ bool define-primitive-type
<c-type>
math:float >>class
math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
[ set-alien-float ] >>setter
4 >>size
4 >>align
4 >>align-first
@ -426,7 +311,7 @@ SYMBOLS:
math:float >>class
math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
[ set-alien-double ] >>setter
8 >>size
8-byte-alignment
"from_double" >>boxer
@ -436,14 +321,40 @@ SYMBOLS:
\ double define-primitive-type
cell 8 = [
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ int define-primitive-type
<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_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uint define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
8 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ longlong define-primitive-type
@ -453,9 +364,9 @@ SYMBOLS:
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
8 >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ ulonglong define-primitive-type
@ -474,6 +385,30 @@ SYMBOLS:
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
<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
\ uint define-primitive-type
<long-long-type>
integer >>class
integer >>boxed-class
@ -505,6 +440,13 @@ SYMBOLS:
\ uint c-type \ uintptr_t typedef
\ uint c-type \ size_t typedef
] if
cpu ppc? \ uint \ uchar ? c-type clone
[ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot
object >>boxed-class
\ bool define-primitive-type
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

27
basis/alien/data/data-docs.factor
View File

@ -21,11 +21,6 @@ HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
HELP: byte-array>memory
{ $values { "byte-array" byte-array } { "base" c-ptr } }
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
@ -65,6 +60,8 @@ $nl
}
"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
@ -75,9 +72,7 @@ $nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsections memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsections memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsections byte-array>memory } ;
{ $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:"
@ -85,7 +80,7 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
{ "Instances of " { $link alien } "." }
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
{ "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
{ "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 }
@ -110,8 +105,8 @@ $nl
"Important guidelines for passing data in byte arrays:"
{ $subsections "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsections POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsections "alien.enums" POSTPONE: ENUM: }
"C types can be aliased for convenience and consistency with native library documentation:"
{ $subsections POSTPONE: TYPEDEF: }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsections "alien.destructors" }
@ -140,13 +135,13 @@ HELP: <c-direct-array>
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
"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
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
"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 converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
"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
@ -155,7 +150,9 @@ $nl
}
"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 char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
"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." ;

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

@ -1,7 +1,8 @@
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words ;
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences words
macros combinators generalizations ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
@ -48,7 +49,7 @@ M: word <c-direct-array>
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
binary-object [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
@ -62,14 +63,46 @@ M: memory-stream stream-read
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
[ 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 abl to access scope-allocated data.
;
MACRO: (local-allots) ( c-types -- quot )
[ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
MACRO: box-values ( c-types -- quot )
[ c-type-boxer-quot ] map '[ _ spread ] ;
MACRO: out-parameters ( c-types -- quot )
[ length ] [ [ '[ 0 _ alien-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 finish -- values )
[ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
(cleanup-allot) ; inline

0
basis/half-floats/authors.txt → basis/alien/debugger/authors.txt
View File

10
basis/alien/debugger/debugger.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2010 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.parser summary sequences accessors
prettyprint ;
IN: alien.debugger
M: no-c-type summary name>> unparse "“" "” is not a C type" surround ;
M: *-in-c-type-name summary
name>> "Cannot define a C type “" "” that ends with an asterisk (*)" surround ;

36
basis/alien/enums/enums-docs.factor Normal file
View File

@ -0,0 +1,36 @@
! 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." } ;
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 symbols and integers."
$nl
"Defining enums at run-time:"
{ $subsection define-enum }
"Conversions between enums and integers:"
{ $subsections enum>number number>enum } ;
{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
ABOUT: "alien.enums"

35
basis/alien/enums/enums-tests.factor Normal file
View File

@ -0,0 +1,35 @@
! 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

55
basis/alien/enums/enums.factor Normal file
View File

@ -0,0 +1,55 @@
! (c)2010 Joe Groff, Erik Charlebois bsd license
USING: accessors alien.c-types arrays combinators delegate fry
generic.parser kernel macros math parser sequences words words.symbol ;
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: symbol 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 -- )
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 @ ] ;
<PRIVATE
: define-enum-value ( class value -- )
"enum-value" set-word-prop ;
: define-enum-members ( member-names -- )
[
[ first define-symbol ]
[ first2 define-enum-value ] bi
] each ;
: define-enum-constructor ( word -- )
[ name>> "<" ">" surround create-in ] keep
[ number>enum ] curry (( number -- enum )) define-inline ;
PRIVATE>
: define-enum ( word base-type members -- )
[ dup define-enum-constructor ] 2dip
dup define-enum-members
<enum-c-type> swap typedef ;
PREDICATE: enum-c-type-word < c-type-word
"c-type" word-prop enum-c-type? ;

59
basis/alien/fortran/fortran-tests.factor
View File

@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
FROM: alien.syntax => pointer: ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran.tests
@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
! fortran-arg-type>c-type
[ c:void* { } ]
[ pointer: c:int { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 3 } { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 0 } { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: fortran_test_record { } ]
[
[
"alien.fortran.tests" use-vocab
@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
] with-manifest
] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "character(1)" fortran-arg-type>c-type ] unit-test
[ c:char* { long } ]
[ pointer: { c:char 17 } { long } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
! fortran-ret-type>c-type
@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
[ c:char { } ]
[ "character(1)" fortran-ret-type>c-type ] unit-test
[ c:void { c:char* long } ]
[ c:void { pointer: { c:char 17 } long } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
[ c:int { } ]
@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: complex-float } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: complex-double } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { c:int 0 } } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: fortran_test_record } ]
[
[
"alien.fortran.tests" use-vocab
@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
! fortran-sig>c-sig
[ c:float { c:void* c:char* c:void* c:void* c:long } ]
[ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ c:char { c:char* c:char* c:void* c:long } ]
[ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
[ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ c:void { c:void* c:char* c:char* c:void* c:long } ]
[ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "funtimes_"
{ c:char* c:void* c:void* c:void* c:void* c:long }
{ pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
alien-invoke
] 6 nkeep
! [fortran-results>]
@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ void* void* }
{ pointer: complex-float pointer: { c:float 0 } }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long }
{ pointer: { c:char 20 } long }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long c:char* c:void* c:char* c:long c:long }
{ pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
alien-invoke
] 7 nkeep
! [fortran-results>]
@ -321,16 +322,16 @@ f2c-abi fortran-abi [
[ { c:char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ pointer: c:char { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
[ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ c:void { void* } ]
[ c:void { pointer: { c:float 0 } } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
[ { char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
[ c:char* { c:long } ]
[ pointer: c:char { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
[ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ c:void { c:void* } ]
[ c:void { pointer: { complex-double 3 } } ]
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
] with-variable

41
basis/alien/fortran/fortran.factor Normal file → Executable file
View File

@ -1,11 +1,12 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.data alien.parser
grouping alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system alien.libraries ;
USING: accessors alien alien.c-types alien.complex alien.data
alien.parser grouping alien.strings alien.syntax arrays ascii
assocs byte-arrays combinators combinators.short-circuit fry
generalizations kernel lexer macros math math.parser namespaces
parser sequences sequences.generalizations splitting
stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects
math.ranges math.order sorting strings system alien.libraries ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran
@ -13,8 +14,8 @@ SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
"I77" "libI77.so" "cdecl" add-library
"F77" "libF77.so" "cdecl" add-library ;
"I77" "libI77.so" cdecl add-library
"F77" "libF77.so" cdecl add-library ;
os netbsd? [ add-f2c-libraries ] when
>>
@ -42,11 +43,11 @@ library-fortran-abis [ H{ } clone ] initialize
[ "__" append ] [ "_" append ] if ;
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
M: f2c-abi fortran-c-abi cdecl ;
M: g95-abi fortran-c-abi cdecl ;
M: gfortran-abi fortran-c-abi cdecl ;
M: intel-unix-abi fortran-c-abi cdecl ;
M: intel-windows-abi fortran-c-abi cdecl ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
@ -114,7 +115,7 @@ MACRO: size-case-type ( cases -- )
[ append-dimensions ] bi ;
: new-fortran-type ( out? dims size class -- type )
new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
new [ [ size<< ] [ dims<< ] [ out?<< ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type )
@ -392,13 +393,13 @@ PRIVATE>
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
[ (fortran-type>c-type) resolve-pointer-type ]
[ (fortran-type>c-type) <pointer> ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
c:void swap
[ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
[ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
@ -434,15 +435,15 @@ MACRO: fortran-invoke ( return library function parameters -- )
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
f current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
scan current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ current-library set ]
[ set-fortran-abi ] bi ;

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

@ -6,7 +6,7 @@ IN: alien.libraries
HELP: <library>
{ $values
{ "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ "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 } "." } ;
@ -19,7 +19,7 @@ HELP: library
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
{ { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
{ { $snippet "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" }
}
} ;
@ -43,7 +43,7 @@ HELP: load-library
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $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. 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
@ -53,8 +53,8 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
" [ drop ]"
"} cond >>"
}

12
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors sequences system io.pathnames ;
kernel namespaces destructors sequences strings
system io.pathnames ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -12,7 +13,7 @@ SYMBOL: libraries
libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
TUPLE: library { path string } { abi abi initial: cdecl } dll ;
ERROR: no-library name ;
@ -36,7 +37,12 @@ M: library dispose dll>> [ dispose ] when* ;
[ <library> swap libraries get set-at ] 3bi ;
: library-abi ( library -- abi )
library [ abi>> ] [ "cdecl" ] if* ;
library [ abi>> ] [ cdecl ] if* ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYMBOL: deploy-libraries

3
basis/alien/parser/authors.txt Normal file
View File

@ -0,0 +1,3 @@
Slava Pestov
Doug Coleman
Joe Groff

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

@ -18,25 +18,26 @@ CONSTANT: eleven 11
[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
[ void* ] [ "int*" parse-c-type ] unit-test
[ void* ] [ "int**" parse-c-type ] unit-test
[ void* ] [ "int***" parse-c-type ] unit-test
[ void* ] [ "int****" parse-c-type ] unit-test
[ char* ] [ "char*" parse-c-type ] unit-test
[ void* ] [ "char**" parse-c-type ] unit-test
[ void* ] [ "char***" parse-c-type ] unit-test
[ void* ] [ "char****" parse-c-type ] unit-test
[ 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
[ c-string ] [ "c-string" parse-c-type ] unit-test
[ char2 ] [ "char2" parse-c-type ] unit-test
[ char* ] [ "char2*" parse-c-type ] unit-test
[ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
] with-file-vocabs
FUNCTION: void* alien-parser-effect-test ( int *arg1 float arg2 ) ;
FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
[ (( arg1 arg2 -- void* )) ] [
\ alien-parser-effect-test "declared-effect" word-prop
\ alien-parser-function-effect-test "declared-effect" word-prop
] 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
! Reported by mnestic

155
basis/alien/parser/parser.factor Normal file → Executable file
View File

@ -1,12 +1,14 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! 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.parser
alien.libraries arrays assocs classes combinators
combinators.short-circuit compiler.units effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
USING: accessors alien alien.c-types alien.libraries arrays
assocs classes combinators combinators.short-circuit
compiler.units effects grouping kernel parser sequences
splitting words fry locals lexer namespaces summary math
vocabs.parser words.constant ;
IN: alien.parser
SYMBOL: current-library
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
@ -18,97 +20,156 @@ IN: alien.parser
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: valid-c-type? ( c-type -- ? )
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
{ [ 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 dup "{" =
[ drop \ } parse-until >array ]
[ parse-c-type ] if ;
scan {
{ [ 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" } reset-props ] bi ] when
{
"c-type"
"pointer-c-type"
"callback-effect"
"callback-library"
} reset-props ;
: CREATE-C-TYPE ( -- word )
scan current-vocab create {
ERROR: *-in-c-type-name name ;
: validate-c-type-name ( name -- name )
dup "*" tail?
[ *-in-c-type-name ] when ;
: (CREATE-C-TYPE) ( word -- word )
validate-c-type-name current-vocab create {
[ fake-definition ]
[ set-word ]
[ reset-c-type ]
[ ]
} cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi
[ parse-c-type ] dip ;
: CREATE-C-TYPE ( -- word )
scan (CREATE-C-TYPE) ;
: parse-arglist ( parameters return -- types effect )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ name>> 1array ] if-void ]
bi* <effect> ;
<PRIVATE
GENERIC: return-type-name ( type -- name )
M: object return-type-name drop "void" ;
M: word return-type-name name>> ;
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
: parse-pointers ( type name -- type' name' )
"*" ?head
[ [ <pointer> ] dip parse-pointers ] when ;
: next-enum-member ( members name value -- members value' )
[ 2array suffix! ] [ 1 + ] bi ;
: parse-enum-name ( -- name )
scan (CREATE-C-TYPE) dup save-location ;
: parse-enum-base-type ( -- base-type token )
scan dup "<" =
[ drop scan-object scan ]
[ [ int ] dip ] if ;
: parse-enum-member ( members name value -- members value' )
over "{" =
[ 2drop scan create-in scan-object next-enum-member "}" expect ]
[ [ create-in ] dip next-enum-member ] if ;
: parse-enum-members ( members counter token -- members )
dup ";" = not
[ swap parse-enum-member scan 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 parse-pointers ;
:: (scan-c-args) ( end-marker types names -- )
scan :> type-str
type-str end-marker = [
type-str { "(" ")" } member? [
type-str parse-c-type :> type
scan "," ?tail drop :> name
type name parse-pointers :> ( type' name' )
type' types push name' names push
] unless
end-marker types names (scan-c-args)
] unless ;
: scan-c-args ( end-marker -- types names )
V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return library function parameters -- word quot effect )
return function normalize-c-arg :> ( return function )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
: function-effect ( names return -- effect )
[ { } ] [ return-type-name 1array ] if-void <effect> ;
: parse-arg-tokens ( -- tokens )
";" parse-tokens [ "()" subseq? not ] filter ;
: create-function ( name -- word )
create-in dup reset-generic ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan parse-arg-tokens make-function ;
:: (make-function) ( return function library types names -- quot effect )
return library function types function-quot
names return function-effect ;
: define-function ( return library function parameters -- )
make-function define-declared ;
:: 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 ( lib return type-name parameters -- word quot effect )
return type-name normalize-c-arg :> ( return type-name )
:: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> ( types callback-effect )
type-word callback-effect "callback-effect" set-word-prop
type-word names return function-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
scan scan parse-arg-tokens make-callback-type ;
current-library get
scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
PREDICATE: alien-function-alias-word < word
def>> {
[ length 5 = ]
[ last \ alien-invoke eq? ]
} 1&& ;
PREDICATE: alien-function-word < alien-function-alias-word
[ def>> third ] [ name>> ] bi = ;
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;
: global-quot ( type word -- quot )
swap [ name>> current-library get ] dip
'[ _ _ address-of 0 _ alien-value ] ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

55
basis/alien/prettyprint/prettyprint-tests.factor Normal file
View File

@ -0,0 +1,55 @@
USING: alien.c-types alien.prettyprint alien.syntax
io.streams.string see tools.test prettyprint ;
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
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

87
basis/alien/prettyprint/prettyprint.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators alien alien.strings alien.c-types
alien.parser alien.syntax arrays assocs effects math.parser
prettyprint.backend prettyprint.custom prettyprint.sections
definitions see see.private sequences strings words ;
USING: accessors kernel combinators alien alien.enums
alien.strings alien.c-types alien.parser alien.syntax arrays
assocs effects math.parser prettyprint prettyprint.backend
prettyprint.custom prettyprint.sections definitions see
see.private sequences strings words ;
IN: alien.prettyprint
M: alien pprint*
@ -19,11 +20,29 @@ M: c-type-word definer drop \ C-TYPE: f ;
M: c-type-word definition drop f ;
M: c-type-word declarations. drop ;
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
<PRIVATE
GENERIC: pointer-string ( pointer -- string/f )
M: object pointer-string drop f ;
M: word pointer-string [ record-vocab ] [ name>> ] bi ;
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
GENERIC: c-type-string ( c-type -- string )
M: word c-type-string [ record-vocab ] [ name>> ] bi ;
M: pointer c-type-string dup pointer-string [ ] [ unparse ] ?if ;
M: wrapper c-type-string wrapped>> c-type-string ;
M: array c-type-string
unclip
[ [ unparse "[" "]" surround ] map ]
[ c-type-string ] bi*
prefix "" join ;
PRIVATE>
: pprint-c-type ( c-type -- )
[ c-type-string ] keep present-text ;
M: pointer pprint*
<flow \ pointer: pprint-word to>> pprint* block> ;
M: typedef-word definer drop \ TYPEDEF: f ;
@ -48,22 +67,36 @@ M: typedef-word synopsis*
: 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
M: alien-function-alias-word definer
drop \ FUNCTION-ALIAS: \ ; ;
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-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> fourth ] [ stack-effect in>> ] bi
pprint-function-args
")" text block>
]
[ [ pprint-word ] pprint-function ]
} cleave ;
M: alien-callback-type-word definer
@ -74,12 +107,24 @@ M: alien-callback-type-word synopsis*
[ seeing-word ]
[ "callback-library" word-prop pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ def>> first first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> second ] [ "callback-effect" word-prop in>> ] bi
[ 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 ]
[ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
} cleave ;
M: enum-c-type-word definition
c-type members>> ;

6
basis/alien/remote-control/remote-control.factor
View File

@ -6,14 +6,14 @@ eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
void* { char* } "cdecl"
void* { c-string } cdecl
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
void { } "cdecl" [ yield ] alien-callback ;
void { } cdecl [ yield ] alien-callback ;
: sleep-callback ( -- callback )
void { long } "cdecl" [ sleep ] alien-callback ;
void { long } cdecl [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline

60
basis/alien/syntax/syntax-docs.factor
View File

@ -1,6 +1,6 @@
IN: alien.syntax
USING: alien alien.c-types alien.parser alien.libraries
classes.struct help.markup help.syntax see ;
USING: alien alien.c-types alien.enums alien.libraries classes.struct
help.markup help.syntax see ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
@ -26,9 +26,9 @@ HELP: LIBRARY:
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
HELP: FUNCTION:
{ $syntax "FUNCTION: return name ( parameters )" }
{ $syntax "FUNCTION: return name ( parameters ) ;" }
{ $values { "return" "a C return type" } { "name" "a C function name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new word " { $snippet "name" } " which calls a C library function with the same name, in the logical library given by the most recent " { $link POSTPONE: LIBRARY: } " declaration."
{ $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
@ -40,44 +40,55 @@ $nl
}
"You can define a word for invoking it:"
{ $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler"
"LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
"\"the question\" 42 the_answer"
"The answer to the question is 42."
} }
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
"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 "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. The following definitions are equivalent:"
{ $code
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
"FUNCTION: void glHint GLenum target GLenum mode ;"
} } ;
}
"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" } " if ." }
{ $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: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." }
{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
HELP: ENUM:
{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
{ $values { "type" "a name to typedef to int or f" } { "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 "C-ENUM: red green blue ;" }
"It is equivalent to the following series of definitions:"
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
{ $code "ENUM: color_t red { green 3 } blue ;" }
"The following expression returns true:"
{ $code "3 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
} ;
HELP: C-TYPE:
{ $syntax "C-TYPE: type" }
{ $values { "type" "a new C type" } }
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
{ $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 } "."
{ $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 also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
@ -108,15 +119,6 @@ HELP: typedef
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }

40
basis/alien/syntax/syntax.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser words.constant alien.libraries ;
USING: accessors arrays alien alien.c-types alien.enums alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects assocs
combinators lexer strings.parser alien.parser fry vocabs.parser
words.constant alien.libraries ;
IN: alien.syntax
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
@ -13,10 +13,14 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: LIBRARY: scan current-library set ;
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
scan create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
(CALLBACK:) define-inline ;
@ -24,26 +28,16 @@ SYNTAX: CALLBACK:
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE dup save-location typedef ;
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
SYNTAX: ENUM:
parse-enum define-enum ;
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] append! ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
scan current-library get '[ _ _ address-of ] append! ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
SYNTAX: pointer:
scan-c-type <pointer> suffix! ;

4
basis/base64/base64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
sequences strings ;
IN: base64
ERROR: malformed-base64 ;
@ -35,7 +35,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1 + [ 76 = [ crlf ] when ]
1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
[ 76 mod column set ] bi
] when* ;

4
basis/biassocs/biassocs.factor
View File

@ -13,9 +13,9 @@ TUPLE: biassoc from to ;
M: biassoc assoc-size from>> assoc-size ;
M: biassoc at* from>> at* ;
M: biassoc at* from>> at* ; inline
M: biassoc value-at* to>> at* ;
M: biassoc value-at* to>> at* ; inline
: once-at ( value key assoc -- )
2dup key? [ 3drop ] [ set-at ] if ;

4
basis/binary-search/binary-search-tests.factor
View File

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

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

@ -1,41 +1,29 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators hints arrays ;
USING: accessors arrays combinators hints kernel locals math
math.order sequences sequences.private ;
IN: binary-search
<PRIVATE
: midpoint ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline
:: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
from to + 2/ :> midpoint@
midpoint@ seq nth-unsafe :> midpoint
: decide ( quot seq -- quot seq <=> )
[ midpoint swap call ] 2keep rot ; inline
: finish ( quot slice -- i elt )
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
to from - 1 <= [
midpoint@ midpoint
] [
decide {
{ +eq+ [ finish ] }
{ +lt+ [ [ (head) ] keep-searching ] }
{ +gt+ [ [ (tail) ] keep-searching ] }
midpoint quot call {
{ +eq+ [ midpoint@ midpoint ] }
{ +lt+ [ seq from midpoint@ quot (search) ] }
{ +gt+ [ seq midpoint@ to quot (search) ] }
} case
] if ; inline recursive
PRIVATE>
: search ( seq quot -- i elt )
over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
: search ( seq quot: ( elt -- <=> ) -- i elt )
over empty? [ 2drop f f ] [ [ 0 over length ] dip (search) ] if ;
inline
: natural-search ( obj seq -- i elt )

6
basis/bit-arrays/bit-arrays-tests.factor
View File

@ -1,4 +1,4 @@
USING: sequences sequences.private arrays bit-arrays kernel
USING: alien sequences sequences.private arrays bit-arrays kernel
tools.test math random ;
IN: bit-arrays.tests
@ -79,4 +79,8 @@ IN: bit-arrays.tests
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
[ 1 ] [ ?{ f t f t } byte-length ] unit-test
[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

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

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
USING: alien alien.data accessors io.binary math math.bitwise
alien.accessors kernel kernel.private sequences
sequences.private byte-arrays parser prettyprint.custom fry
locals ;
IN: bit-arrays
TUPLE: bit-array
@ -13,11 +14,10 @@ TUPLE: bit-array
: n>byte ( m -- n ) -3 shift ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
: bit-index ( n bit-array -- bit# byte# byte-array )
[ >fixnum bit/byte ] [ underlying>> ] bi* ; inline
: bits>cells ( m -- n ) 31 + -5 shift ; inline
@ -25,7 +25,7 @@ TUPLE: bit-array
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
'[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
@ -47,12 +47,13 @@ PRIVATE>
M: bit-array length length>> ; inline
M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
bit-index nth-unsafe swap bit? ; inline
:: toggle-bit ( ? n x -- y )
x n ? [ set-bit ] [ clear-bit ] if ; inline
M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ; inline
bit-index [ toggle-bit ] change-nth-unsafe ; inline
GENERIC: clear-bits ( bit-array -- )
@ -83,25 +84,17 @@ M: bit-array resize
bit-array boa
dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ; inline
M: bit-array byte-length length bits>bytes ; inline
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array )
dup 0 = [
<bit-array>
] [
[ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;
dup 0 =
[ <bit-array> ]
[ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
: bit-array>integer ( bit-array -- n )
0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;
underlying>> le> ;
INSTANCE: bit-array sequence

18
basis/bit-sets/bit-sets-docs.factor Normal file
View File

@ -0,0 +1,18 @@
USING: help.markup help.syntax sequences math ;
IN: bit-sets
ARTICLE: "bit-sets" "Bit sets"
"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
"Bit sets form a class:"
{ $subsection bit-set }
"Constructing new bit sets:"
{ $subsection <bit-set> } ;
ABOUT: "bit-sets"
HELP: bit-set
{ $class-description "The class of bit-array-based " { $link "sets" } "." } ;
HELP: <bit-set>
{ $values { "capacity" integer } { "bit-set" bit-set } }
{ $description "Creates a new bit set with the given capacity. This set is initially empty and can contain as members integers between 0 and " { $snippet "capacity" } "-1." } ;

69
basis/bit-sets/bit-sets-tests.factor
View File

@ -1,17 +1,66 @@
USING: bit-sets tools.test bit-arrays ;
USING: bit-sets tools.test sets kernel bit-arrays ;
IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-union
[ T{ bit-set f ?{ t f t f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } union
] unit-test
[ ?{ f f f f t f } ] [
?{ t f f f t f }
?{ f f t f t f } bit-set-intersect
[ T{ bit-set f ?{ f f f f t f } } ] [
T{ bit-set f ?{ t f f f t f } }
T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
[ ?{ t f t f f f } ] [
?{ t t t f f f }
?{ f t f f t t } bit-set-diff
[ f ] [ T{ bit-set f ?{ t f f f t f } } null? ] unit-test
[ t ] [ T{ bit-set f ?{ f f f f f f } } null? ] unit-test
[ T{ bit-set f ?{ t f t f f f } } ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } diff
] unit-test
[ f ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f t t } } subset?
] unit-test
[ t ] [
T{ bit-set f ?{ t t t f f f } }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ t ] [
{ 0 1 2 }
T{ bit-set f ?{ f t f f f f } } subset?
] unit-test
[ f ] [
T{ bit-set f ?{ f t f f f f } }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ f ] [
{ 1 }
T{ bit-set f ?{ t t t f f f } } subset?
] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
[ t V{ 1 2 3 } ] [
{ 1 2 } 5 <bit-set> set-like
[ bit-set? ] keep
3 over adjoin
members
] unit-test
[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
[ 1 <bit-set> dup clone 0 over adjoin ] unit-test

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

@ -1,10 +1,40 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
IN: bit-sets
TUPLE: bit-set { table bit-array read-only } ;
: <bit-set> ( capacity -- bit-set )
<bit-array> bit-set boa ;
INSTANCE: bit-set set
M: bit-set in?
over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
M: bit-set adjoin
! This is allowed to crash when the elt couldn't go in the set
[ t ] 2dip table>> set-nth ;
M: bit-set delete
! This isn't allowed to crash if the elt wasn't in the set
over integer? [
table>> 2dup bounds-check? [
[ f ] 2dip set-nth
] [ 2drop ] if
] [ 2drop ] if ;
! If you do binary set operations with a bitset, it's expected
! that the other thing can also be represented as a bitset
! of the same length.
<PRIVATE
ERROR: check-bit-set-failed ;
: check-bit-set ( bit-set -- bit-set )
dup bit-set? [ check-bit-set-failed ] unless ; inline
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
@ -14,18 +44,43 @@ IN: bit-sets
] dip 2map
] 3bi bit-array boa ; inline
: (bit-set-op) ( set1 set2 -- table1 table2 )
[ set-like ] keep [ table>> ] bi@ ; inline
: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
[ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
PRIVATE>
: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
M: bit-set union
[ bitor ] bit-set-op ;
HINTS: bit-set-union bit-array bit-array ;
M: bit-set intersect
[ bitand ] bit-set-op ;
: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
M: bit-set diff
[ bitnot bitand ] bit-set-op ;
HINTS: bit-set-intersect bit-array bit-array ;
M: bit-set subset?
[ intersect ] keep = ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
M: bit-set members
[ table>> length iota ] keep [ in? ] curry filter ;
HINTS: bit-set-diff bit-array bit-array ;
<PRIVATE
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
: bit-set-like ( set bit-set -- bit-set' )
! This crashes if there are keys that can't be put in the bit set
over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
[ drop ] [
[ members ] dip table>> length <bit-set>
[ [ adjoin ] curry each ] keep
] if ;
PRIVATE>
M: bit-set set-like
bit-set-like check-bit-set ; inline
M: bit-set clone
table>> clone bit-set boa ;

12
basis/bitstreams/bitstreams.factor
View File

@ -64,7 +64,7 @@ GENERIC: poke ( value n bitstream -- )
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
: set-abp ( abp bitstream -- )
[ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
[ 8 /mod ] dip [ bit-pos<< ] [ byte-pos<< ] bi ; inline
: seek ( n bitstream -- )
[ get-abp + ] [ set-abp ] bi ; inline
@ -117,11 +117,11 @@ M:: lsb0-bit-writer poke ( value n bs -- )
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
zero-widthed bs (>>widthed)
zero-widthed bs widthed<<
remainder widthed>bytes
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
[ bs bytes>> push-all ] [ bs widthed<< ] bi*
] [
byte bs (>>widthed)
byte bs widthed<<
] if ;
: enough-bits? ( n bs -- ? )
@ -146,10 +146,10 @@ ERROR: not-enough-bits n bit-reader ;
n 8 /mod :> ( #bytes #bits )
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
8 - bs (>>bit-pos)
8 - bs bit-pos<<
bs [ 1 + ] change-byte-pos drop
] [
bs (>>bit-pos)
bs bit-pos<<
] if ;
:: (peek) ( n bs endian> subseq-endian -- bits )

14
basis/bootstrap/compiler/compiler.factor
View File

@ -20,10 +20,8 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
] when
{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when
{ "boostrap.compiler" "debugger" } "alien.debugger" require-when
"cpu." cpu name>> append require
@ -37,7 +35,7 @@ gc
[ optimized? not ] filter compile ;
"debug-compiler" get [
nl
"Compiling..." write flush
@ -59,7 +57,7 @@ gc
curry compose uncurry
array-nth set-array-nth length>>
array-nth set-array-nth
wrap probe
@ -119,4 +117,8 @@ gc
" done" print flush
"alien.syntax" require
"alien.complex" require
"io.streams.byte-array.fast" require
] unless

2
basis/bootstrap/compiler/timing/tags.txt
View File

@ -1 +1 @@
untested
not loaded

16
basis/bootstrap/compiler/timing/timing.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel make sequences tools.annotations tools.crossref ;
QUALIFIED: compiler.cfg.builder
QUALIFIED: compiler.cfg.linear-scan
QUALIFIED: compiler.cfg.mr
QUALIFIED: compiler.cfg.optimizer
QUALIFIED: compiler.cfg.stacks.finalize
QUALIFIED: compiler.cfg.stacks.global
QUALIFIED: compiler.cfg.finalization
QUALIFIED: compiler.codegen
QUALIFIED: compiler.tree.builder
QUALIFIED: compiler.tree.optimizer
QUALIFIED: compiler.cfg.liveness
QUALIFIED: compiler.cfg.liveness.ssa
IN: bootstrap.compiler.timing
: passes ( word -- seq )
@ -19,7 +19,7 @@ IN: bootstrap.compiler.timing
: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
: machine-passes ( -- seq ) \ compiler.cfg.finalization:finalize-cfg passes ;
: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
@ -29,14 +29,14 @@ IN: bootstrap.compiler.timing
\ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
\ compiler.cfg.builder:build-cfg ,
\ compiler.cfg.stacks.global:compute-global-sets ,
\ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
\ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
\ compiler.cfg.mr:build-mr ,
\ compiler.cfg.finalization:finalize-cfg ,
machine-passes %
linear-scan-passes %
\ compiler.codegen:generate ,
\ compiler.cfg.liveness:compute-live-sets ,
\ compiler.cfg.liveness.ssa:compute-ssa-live-sets ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each

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

@ -1,4 +1,4 @@
USING: vocabs.loader vocabs kernel ;
IN: bootstrap.handbook
"bootstrap.help" vocab [ "help.handbook" require ] when
{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when

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

@ -6,12 +6,10 @@ IN: bootstrap.help
: load-help ( -- )
"help.lint" require
"help.vocabs" require
"alien.syntax" require
"compiler" require
t load-help? set-global
[ vocab ] load-vocab-hook [
[ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [
dictionary get values
[ docs-loaded?>> not ] filter
[ load-docs ] each

25
basis/bootstrap/image/download/download.factor
View File

@ -18,20 +18,19 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
bi = not
] [ drop t ] if ;
: download-image ( arch -- )
url swap boot-image-name >url derive-url download ;
: verify-image ( image -- )
need-new-image? [ "Boot image corrupt" throw ] when ;
: maybe-download-image ( arch -- )
dup boot-image-name need-new-image? [
dup download-image
need-new-image? [
"Boot image corrupt, or checksums.txt on server out of date" throw
] when
] [
"Boot image up to date" print
drop
] if ;
: download-image ( image -- )
[ url swap >url derive-url download ]
[ verify-image ]
bi ;
: download-my-image ( -- ) my-arch maybe-download-image ;
: maybe-download-image ( image -- ? )
dup need-new-image?
[ download-image t ] [ drop f ] if ;
: download-my-image ( -- )
my-arch boot-image-name maybe-download-image drop ;
MAIN: download-my-image

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

@ -3,11 +3,11 @@
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences strings sbufs vectors words quotations
assocs system layouts splitting grouping growable classes
classes.private classes.builtin classes.tuple
classes.tuple.private vocabs vocabs.loader source-files
definitions debugger quotations.private combinators
prettyprint sequences sequences.generalizations strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.private classes.builtin
classes.tuple classes.tuple.private vocabs vocabs.loader
source-files definitions debugger quotations.private combinators
combinators.short-circuit math.order math.private accessors
slots.private generic.single.private compiler.units
compiler.constants fry locals bootstrap.image.syntax
@ -15,10 +15,11 @@ generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
[ dup "winnt" = "winnt" "unix" ? ] dip
{
{ "ppc" [ "-ppc" append ] }
{ "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
[ nip ]
{ "ppc" [ drop "-ppc" append ] }
{ "x86.32" [ nip "-x86.32" append ] }
{ "x86.64" [ nip "-x86.64" append ] }
} case ;
: my-arch ( -- arch )
@ -32,7 +33,7 @@ IN: bootstrap.image
: images ( -- seq )
{
"x86.32"
"winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
@ -129,8 +130,8 @@ SYMBOL: jit-literals
: jit-vm ( offset rc -- )
[ jit-parameter ] dip rt-vm jit-rel ;
: jit-dlsym ( name library rc -- )
rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
: jit-dlsym ( name rc -- )
rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len

5
basis/bootstrap/stage2.factor
View File

@ -51,9 +51,11 @@ SYMBOL: bootstrap-time
: save/restore-error ( quot -- )
error get-global
original-error get-global
error-continuation get-global
[ call ] 2dip
[ call ] 3dip
error-continuation set-global
original-error set-global
error set-global ; inline
@ -89,6 +91,7 @@ SYMBOL: bootstrap-time
run-bootstrap-init
f error set-global
f original-error set-global
f error-continuation set-global
nano-count swap - bootstrap-time set-global

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

@ -1,11 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel io.thread threads
USING: vocabs.loader kernel io.thread threads
compiler.utilities namespaces ;
IN: bootstrap.threads
"debugger" vocab [
"debugger.threads" require
] when
{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
[ yield ] yield-hook set-global
[ yield ] yield-hook set-global

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

@ -1,4 +1,4 @@
USING: vocabs.loader sequences ;
USING: vocabs.loader sequences system combinators ;
IN: bootstrap.tools
{
@ -23,3 +23,8 @@ IN: bootstrap.tools
"vocabs.refresh"
"vocabs.refresh.monitor"
} [ require ] each
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
} cond

4
basis/bootstrap/ui/tools/tools.factor
View File

@ -4,9 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
"ui.backend.cocoa" vocab [
"ui.backend.cocoa.tools" require
] when
{ "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when
"ui.tools.walker" require
] when

12
basis/boxes/boxes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ;
IN: boxes
@ -11,16 +11,18 @@ ERROR: box-full box ;
: >box ( value box -- )
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
[ box-full ] [ t >>occupied value<< ] if ; inline
ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value )
dup occupied>>
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
check-box [ f ] change-value f >>occupied drop ; inline
: ?box ( box -- value/f ? )
dup occupied>> [ box> t ] [ drop f f ] if ;
dup occupied>> [ box> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline

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

@ -1,6 +1,8 @@
! Copyright (c) 2007 Sampo Vuori
! Copyright (c) 2008 Matthew Willis
!
! Adapted from cairo.h, version 1.5.14
! License: http://factorcode.org/license.txt
@ -10,15 +12,15 @@ alien.libraries classes.struct ;
IN: cairo.ffi
<< {
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond >>
LIBRARY: cairo
FUNCTION: int cairo_version ( ) ;
FUNCTION: char* cairo_version_string ( ) ;
FUNCTION: c-string cairo_version_string ( ) ;
TYPEDEF: int cairo_bool_t
@ -38,14 +40,13 @@ TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
[ void { void* } "cdecl" ] dip alien-callback ; inline
[ void { pointer: void } cdecl ] dip alien-callback ; inline
! See cairo.h for details
STRUCT: cairo_user_data_key_t
{ unused int } ;
TYPEDEF: int cairo_status_t
C-ENUM:
ENUM: cairo_status_t
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_INVALID_RESTORE
@ -79,11 +80,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
@ -125,8 +126,7 @@ FUNCTION: void
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
TYPEDEF: int cairo_operator_t
C-ENUM:
ENUM: cairo_operator_t
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
@ -163,8 +163,7 @@ cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, doub
FUNCTION: void
cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
TYPEDEF: int cairo_antialias_t
C-ENUM:
ENUM: cairo_antialias_t
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
@ -173,8 +172,7 @@ C-ENUM:
FUNCTION: void
cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
TYPEDEF: int cairo_fill_rule_t
C-ENUM:
ENUM: cairo_fill_rule_t
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD ;
@ -184,8 +182,7 @@ cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
FUNCTION: void
cairo_set_line_width ( cairo_t* cr, double width ) ;
TYPEDEF: int cairo_line_cap_t
C-ENUM:
ENUM: cairo_line_cap_t
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE ;
@ -193,8 +190,7 @@ C-ENUM:
FUNCTION: void
cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
TYPEDEF: int cairo_line_join_t
C-ENUM:
ENUM: cairo_line_join_t
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL ;
@ -379,35 +375,30 @@ STRUCT: cairo_font_extents_t
{ max_x_advance double }
{ max_y_advance double } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
ENUM: cairo_font_slant_t
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE ;
TYPEDEF: int cairo_font_weight_t
C-ENUM:
ENUM: cairo_font_weight_t
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD ;
TYPEDEF: int cairo_subpixel_order_t
C-ENUM:
ENUM: cairo_subpixel_order_t
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_BGR
CAIRO_SUBPIXEL_ORDER_VRGB
CAIRO_SUBPIXEL_ORDER_VBGR ;
TYPEDEF: int cairo_hint_style_t
C-ENUM:
ENUM: cairo_hint_style_t
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_SLIGHT
CAIRO_HINT_STYLE_MEDIUM
CAIRO_HINT_STYLE_FULL ;
TYPEDEF: int cairo_hint_metrics_t
C-ENUM:
ENUM: cairo_hint_metrics_t
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
CAIRO_HINT_METRICS_ON ;
@ -463,7 +454,7 @@ cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
! font object inside the the cairo_t.
FUNCTION: void
cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
cairo_select_font_face ( cairo_t* cr, c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
FUNCTION: void
cairo_set_font_size ( cairo_t* cr, double size ) ;
@ -493,19 +484,19 @@ FUNCTION: cairo_scaled_font_t*
cairo_get_scaled_font ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
cairo_text_extents ( cairo_t* cr, c-string utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@ -527,8 +518,7 @@ cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
FUNCTION: cairo_status_t
cairo_font_face_status ( cairo_font_face_t* font_face ) ;
TYPEDEF: int cairo_font_type_t
C-ENUM:
ENUM: cairo_font_type_t
CAIRO_FONT_TYPE_TOY
CAIRO_FONT_TYPE_FT
CAIRO_FONT_TYPE_WIN32
@ -573,7 +563,7 @@ FUNCTION: void
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
@ -640,8 +630,7 @@ cairo_get_target ( cairo_t* cr ) ;
FUNCTION: cairo_surface_t*
cairo_get_group_target ( cairo_t* cr ) ;
TYPEDEF: int cairo_path_data_type_t
C-ENUM:
ENUM: cairo_path_data_type_t
CAIRO_PATH_MOVE_TO
CAIRO_PATH_LINE_TO
CAIRO_PATH_CURVE_TO
@ -682,7 +671,7 @@ cairo_path_destroy ( cairo_path_t* path ) ;
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
FUNCTION: char*
FUNCTION: c-string
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
@ -707,8 +696,7 @@ cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_status ( cairo_surface_t* surface ) ;
TYPEDEF: int cairo_surface_type_t
C-ENUM:
ENUM: cairo_surface_type_t
CAIRO_SURFACE_TYPE_IMAGE
CAIRO_SURFACE_TYPE_PDF
CAIRO_SURFACE_TYPE_PS
@ -731,7 +719,7 @@ FUNCTION: cairo_content_t
cairo_surface_get_content ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
cairo_surface_write_to_png ( cairo_surface_t* surface, c-string filename ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
@ -771,8 +759,7 @@ cairo_surface_show_page ( cairo_surface_t* surface ) ;
! Image-surface functions
TYPEDEF: int cairo_format_t
C-ENUM:
ENUM: cairo_format_t
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
@ -786,7 +773,7 @@ FUNCTION: int
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
cairo_image_surface_create_for_data ( char* data, cairo_format_t format, int width, int height, int stride ) ;
FUNCTION: uchar*
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
@ -804,7 +791,7 @@ FUNCTION: int
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png ( char* filename ) ;
cairo_image_surface_create_from_png ( c-string filename ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
@ -844,8 +831,7 @@ cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* k
FUNCTION: cairo_status_t
cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
TYPEDEF: int cairo_pattern_type_t
C-ENUM:
ENUM: cairo_pattern_type_t
CAIRO_PATTERN_TYPE_SOLID
CAIRO_PATTERN_TYPE_SURFACE
CAIRO_PATTERN_TYPE_LINEAR
@ -866,8 +852,7 @@ cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
TYPEDEF: int cairo_extend_t
C-ENUM:
ENUM: cairo_extend_t
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
@ -879,8 +864,7 @@ cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
FUNCTION: cairo_extend_t
cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
TYPEDEF: int cairo_filter_t
C-ENUM:
ENUM: cairo_filter_t
CAIRO_FILTER_FAST
CAIRO_FILTER_GOOD
CAIRO_FILTER_BEST

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

@ -8,7 +8,7 @@ HELP: duration
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
HELP: timestamp
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
@ -76,27 +76,27 @@ HELP: day-abbreviation3
} related-words
HELP: average-month
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
{ $values { "ratio" ratio } }
{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
{ $values { "integer" integer } }
{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number

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

@ -176,3 +176,13 @@ IN: calendar.tests
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
[ t ] [
2009 1 29 <date> 1 months time+
2009 3 1 <date> =
] unit-test
[ t ] [
2008 1 29 <date> 1 months time+
2008 2 29 <date> =
] unit-test

26
basis/calendar/calendar.factor
View File

@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
: days-per-year ( -- ratio ) 3652425/10000 ; inline
: hours-per-year ( -- ratio ) 876582/100 ; inline
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
CONSTANT: average-month 30+5/12
CONSTANT: months-per-year 12
CONSTANT: days-per-year 3652425/10000
CONSTANT: hours-per-year 876582/100
CONSTANT: minutes-per-year 5259492/10
CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
@ -170,18 +170,6 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: year ( obj -- n )
M: integer year ;
M: timestamp year year>> ;
GENERIC: month ( obj -- n )
M: integer month ;
M: timestamp month month>> ;
GENERIC: day ( obj -- n )
M: integer day ;
M: timestamp day day>> ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
@ -212,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp )
[ 3 >>month 1 >>day ] when ;
M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
[ + ] curry change-year adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;

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

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
combinators calendar calendar.format.macros present ;
USING: accessors arrays calendar calendar.format.macros
combinators io io.streams.string kernel math math.functions
math.order math.parser present sequences typed ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
@ -272,16 +272,16 @@ ERROR: invalid-timestamp-format ;
: (timestamp>ymd) ( timestamp -- )
{ YYYY "-" MM "-" DD } formatted ;
: timestamp>ymd ( timestamp -- str )
TYPED: timestamp>ymd ( timestamp: timestamp -- str )
[ (timestamp>ymd) ] with-string-writer ;
: (timestamp>hms) ( timestamp -- )
{ hh ":" mm ":" ss } formatted ;
: timestamp>hms ( timestamp -- str )
TYPED: timestamp>hms ( timestamp: timestamp -- str )
[ (timestamp>hms) ] with-string-writer ;
: timestamp>ymdhms ( timestamp -- str )
TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
[
>gmt
{ (timestamp>ymd) " " (timestamp>hms) } formatted

8
basis/calendar/model/model.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: calendar namespaces models threads kernel init ;
IN: calendar.model
@ -15,5 +15,7 @@ SYMBOL: time
(time-thread)
] "Time model update" spawn drop ;
f <model> time set-global
[ time-thread ] "calendar.model" add-startup-hook
[
f <model> time set-global
time-thread
] "calendar.model" add-startup-hook

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

@ -21,7 +21,7 @@ IN: calendar.unix
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime tm memory>struct ;
f time <time_t> localtime ;
: timezone-name ( -- string )
get-time zone>> ;

10
basis/channels/channels.factor
View File

@ -17,7 +17,7 @@ GENERIC: from ( channel -- value )
<PRIVATE
: wait ( channel -- )
[ senders>> push ] curry
[ self ] dip senders>> push
"channel send" suspend drop ;
: (to) ( value receivers -- )
@ -36,7 +36,7 @@ M: channel to ( value channel -- )
[ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
[
notify senders>>
[ (from) ] unless-empty
] curry "channel receive" suspend ;
[ self ] dip
notify senders>>
[ (from) ] unless-empty
"channel receive" suspend ;

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

@ -29,7 +29,7 @@ M: md5 initialize-checksum-state drop <md5-state> ;
: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
[ (>>old-state) ] [ (>>state) ] bi ;
[ old-state<< ] [ state<< ] bi ;
CONSTANT: T
$[
@ -182,10 +182,10 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ;
] each
] unless ;
: byte-array>uint-array-le ( byte-array -- uint-array )
byte-array>le byte-array>uint-array ;
: uint-array-cast-le ( byte-array -- uint-array )
byte-array>le uint-array-cast ;
HINTS: byte-array>uint-array-le byte-array ;
HINTS: uint-array-cast-le byte-array ;
: uint-array>byte-array-le ( uint-array -- byte-array )
underlying>> byte-array>le ;
@ -194,7 +194,7 @@ HINTS: uint-array>byte-array-le uint-array ;
M: md5-state checksum-block ( block state -- )
[
[ byte-array>uint-array-le ] [ state>> ] bi* {
[ uint-array-cast-le ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]

9
basis/checksums/openssl/openssl.factor
View File

@ -1,4 +1,4 @@
! copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types alien.data kernel
continuations destructors sequences io openssl openssl.libcrypto
@ -47,9 +47,10 @@ M: evp-md-context dispose*
: digest-value ( ctx -- value )
handle>>
EVP_MAX_MD_SIZE <byte-array> 0 <int>
[ EVP_DigestFinal_ex ssl-error ] 2keep
*int memory>byte-array ;
{ { int EVP_MAX_MD_SIZE } int }
[ EVP_DigestFinal_ex ssl-error ]
[ memory>byte-array ]
with-out-parameters ;
PRIVATE>

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

@ -4,7 +4,7 @@ USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
sequences.private splitting strings ;
sequences.generalizations sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1
@ -395,7 +395,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
state [ H [ w+ ] 2map ] change-H drop ; inline
M:: sha1-state checksum-block ( bytes state -- )
bytes prepare-sha1-message-schedule state (>>W)
bytes prepare-sha1-message-schedule state W<<
bytes
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;

6
basis/circular/circular.factor
View File

@ -25,7 +25,7 @@ M: circular virtual-exemplar seq>> ; inline
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
circular-wrap (>>start) ; inline
circular-wrap start<< ; inline
: rotate-circular ( circular -- )
[ 1 ] dip change-circular-start ; inline
@ -64,7 +64,7 @@ TUPLE: circular-iterator
<PRIVATE
: (circular-while) ( iterator quot: ( obj -- ? ) -- )
: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
@ -75,5 +75,5 @@ TUPLE: circular-iterator
PRIVATE>
: circular-while ( circular quot: ( obj -- ? ) -- )
: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

5
basis/classes/struct/struct-docs.factor
View File

@ -35,7 +35,8 @@ HELP: STRUCT:
{ "Struct classes cannot have a superclass defined." }
{ "The slots of a struct must all have a type declared. The type must be a C type." }
{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
} } ;
}
"Additionally, structs may use bit fields. A slot specifier may use the syntax " { $snippet "bits: n" } " to specify that the bit width of the slot is " { $snippet "n" } ". Bit width may be specified on signed or unsigned integer slots. The layout of bit fields is not guaranteed to match that of any particular C compiler." } ;
HELP: S{
{ $syntax "S{ class slots... }" }
@ -159,7 +160,7 @@ $nl
"A C function which returns a struct by value:"
{ $code
"USING: alien.syntax ;"
"FUNCTION: Point give_me_a_point ( char* description ) ;"
"FUNCTION: Point give_me_a_point ( c-string description ) ;"
}
"A C function which takes a struct parameter by reference:"
{ $code

93
basis/classes/struct/struct-tests.factor
View File

@ -1,12 +1,14 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts generic.single classes ;
USING: accessors alien alien.c-types alien.data alien.syntax ascii
assocs byte-arrays classes.struct classes.tuple.parser
classes.tuple.private classes.tuple combinators compiler.tree.debugger
compiler.units destructors io.encodings.utf8 io.pathnames
io.streams.string kernel libc literals math mirrors namespaces
prettyprint prettyprint.config see sequences specialized-arrays
system tools.test parser lexer eval layouts generic.single classes
vocabs ;
FROM: math => float ;
FROM: specialized-arrays.private => specialized-array-vocab ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
@ -139,7 +141,7 @@ UNION-STRUCT: struct-test-float-and-bits
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
STRUCT: struct-test-string-ptr
{ x char* } ;
{ x c-string } ;
[ "hello world" ] [
[
@ -209,7 +211,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ name "y" }
{ offset 4 }
{ initial 123 }
{ class integer }
{ class $[ cell 4 = integer fixnum ? ] }
{ type int }
}
T{ struct-slot-spec
@ -233,7 +235,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ name "bits" }
{ offset 0 }
{ type uint }
{ class integer }
{ class $[ cell 4 = integer fixnum ? ] }
{ initial 0 }
}
} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
@ -303,6 +305,12 @@ SPECIALIZED-ARRAY: struct-test-optimization
{ x>> } inlined?
] unit-test
[ ] [
[
struct-test-optimization specialized-array-vocab forget-vocab
] with-compilation-unit
] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
@ -334,6 +342,14 @@ STRUCT: struct-that's-a-word { x int } ;
"struct-class-test-1" parse-stream
] [ error>> error>> unexpected-eof? ] must-fail-with
[
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with
[
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
] [ error>> duplicate-slot-names? ] must-fail-with
! S{ with non-struct type
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
@ -374,6 +390,63 @@ STRUCT: bit-field-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
STRUCT: referent
{ y int } ;
STRUCT: referrer
{ x referent* } ;
[ 57 ] [
[
referrer <struct>
referent malloc-struct &free
57 >>y
>>x
x>> y>>
] with-destructors
] unit-test
STRUCT: self-referent
{ x self-referent* }
{ y int } ;
[ 75 ] [
[
self-referent <struct>
self-referent malloc-struct &free
75 >>y
>>x
x>> y>>
] with-destructors
] unit-test
C-TYPE: forward-referent
STRUCT: backward-referent
{ x forward-referent* }
{ y int } ;
STRUCT: forward-referent
{ x backward-referent* }
{ y int } ;
[ 41 ] [
[
forward-referent <struct>
backward-referent malloc-struct &free
41 >>y
>>x
x>> y>>
] with-destructors
] unit-test
[ 14 ] [
[
backward-referent <struct>
forward-referent malloc-struct &free
14 >>y
>>x
x>> y>>
] with-destructors
] unit-test
cpu ppc? [
STRUCT: ppc-align-test-1
{ x longlong }

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

@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
locals macros make math math.order parser quotations sequences
slots slots.private specialized-arrays vectors words summary
namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
classes.struct.bit-accessors bit-arrays
stack-checker.dependencies system layouts ;
QUALIFIED: math
IN: classes.struct
@ -45,11 +46,11 @@ M: struct >c-ptr
M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
} 2&& ; inline
M: struct hashcode*
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
binary-object <direct-uchar-array> hashcode* ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
@ -100,8 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
[ type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
[ offset>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
@ -112,23 +112,29 @@ M: struct-bit-slot-spec (reader-quot)
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
[ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
[ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
M: struct-bit-slot-spec (writer-quot)
[ offset>> ] [ bits>> ] bi bit-writer
[ >c-ptr ] prepose ;
[ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
MACRO: read-struct-slot ( slot -- )
dup type>> depends-on-c-type
(reader-quot) ;
MACRO: write-struct-slot ( slot -- )
dup type>> depends-on-c-type
(writer-quot) ;
PRIVATE>
M: struct-class boa>object
swap pad-struct-slots
[ <struct> ] [ struct-slots ] bi
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
M: struct-class initial-value* <struct> ; inline
@ -138,10 +144,11 @@ M: struct-class initial-value* <struct> ; inline
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot
nip (reader-quot) ;
dup type>> array? [ dup type>> first define-array-vocab drop ] when
nip '[ _ read-struct-slot ] ;
M: struct-class writer-quot
nip (writer-quot) ;
nip '[ _ write-struct-slot ] ;
: offset-of ( field struct -- offset )
struct-slots slot-named offset>> ; inline
@ -156,30 +163,14 @@ INSTANCE: struct-c-type value-type
M: struct-c-type c-type ;
M: struct-c-type c-type-stack-align? drop f ;
M: struct-c-type base-type ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-c-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-c-type box-parameter
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
M: struct-c-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
M: struct-c-type box-return
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: struct-c-type stack-size
[ heap-size ] [ stack-size ] if-value-struct ;
M: struct-c-type c-struct? drop t ;
: large-struct? ( type -- ? )
{
{ [ dup void? ] [ drop f ] }
{ [ dup base-type struct-c-type? not ] [ drop f ] }
[ return-struct-in-registers? not ]
} cond ;
<PRIVATE
: struct-slot-values-quot ( class -- quot )
@ -193,7 +184,7 @@ M: struct-c-type c-struct? drop t ;
define-inline-method ;
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
binary-object memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
@ -218,10 +209,10 @@ GENERIC: compute-slot-offset ( offset class -- offset' )
M: struct-slot-spec compute-slot-offset
[ type>> over c-type-align-at 8 * align ] keep
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
[ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec compute-slot-offset
[ (>>offset) ] [ bits>> + ] 2bi ;
[ offset<< ] [ bits>> + ] 2bi ;
: compute-struct-offsets ( slots -- size )
0 [ compute-slot-offset ] reduce 8 align 8 /i ;
@ -343,7 +334,7 @@ PRIVATE>
<PRIVATE
: parse-struct-slot ( -- slot )
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
scan {
{ ";" [ f ] }
@ -353,7 +344,8 @@ PRIVATE>
} case ;
: parse-struct-definition ( -- class slots )
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
dup [ name>> ] map check-duplicate-slots ;
PRIVATE>
SYNTAX: STRUCT:
@ -393,4 +385,4 @@ FUNCTOR-SYNTAX: STRUCT:
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when

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

@ -8,10 +8,9 @@ IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
C-ENUM:
NSApplicationDelegateReplySuccess
NSApplicationDelegateReplyCancel
NSApplicationDelegateReplyFailure ;
CONSTANT: NSApplicationDelegateReplySuccess 0
CONSTANT: NSApplicationDelegateReplyCancel 1
CONSTANT: NSApplicationDelegateReplyFailure 2
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline

1
basis/cocoa/cocoa.factor
View File

@ -39,6 +39,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
[
{
"NSAlert"
"NSApplication"
"NSArray"
"NSAutoreleasePool"

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

@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
@
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
: NSFastEnumeration-each ( object quot -- )
: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
: NSFastEnumeration-map ( object quot -- vector )
: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline

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

@ -1,12 +1,11 @@
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc
libc.private lexer init core-foundation fry generalizations
specialized-arrays ;
macros memoize io.encodings.utf8 effects layouts libc lexer init
core-foundation fry generalizations specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
@ -110,7 +109,7 @@ H{
{ "d" c:double }
{ "B" c:bool }
{ "v" c:void }
{ "*" c:char* }
{ "*" c:c-string }
{ "?" unknown_type }
{ "@" id }
{ "#" Class }
@ -217,7 +216,7 @@ ERROR: no-objc-type name ;
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
[ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
@ -237,8 +236,8 @@ ERROR: no-objc-type name ;
: import-objc-class ( name quot -- )
2dup swap define-objc-class-word
over objc_getClass [ drop ] [ call( -- ) ] if
dup objc_getClass [
over class-exists? [ drop ] [ call( -- ) ] if
dup class-exists? [
[ objc_getClass register-objc-methods ]
[ objc_getMetaClass register-objc-methods ] bi
] [ drop ] if ;

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

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa.application cocoa.messages cocoa.classes
cocoa.runtime kernel cocoa alien.c-types core-foundation
core-foundation.arrays ;
USING: alien.c-types alien.data cocoa.application cocoa.messages
cocoa.classes cocoa.runtime cocoa core-foundation
core-foundation.arrays kernel ;
IN: cocoa.nibs
: load-nib ( name -- )
@ -15,5 +15,7 @@ IN: cocoa.nibs
dup [ -> autorelease ] when ;
: nib-objects ( anNSNib -- objects/f )
f f <void*> [ -> instantiateNibWithOwner:topLevelObjects: ] keep
swap [ *void* CF>array ] [ drop f ] if ;
f
{ void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
with-out-parameters
swap [ CF>array ] [ drop f ] if ;

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

@ -36,9 +36,11 @@ DEFER: plist>
NSFastEnumeration-map >hashtable ;
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
NSPropertyListSerialization swap kCFPropertyListImmutable f
{ void* }
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
with-out-parameters
[ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
[

16
basis/cocoa/runtime/runtime.factor
View File

@ -7,11 +7,11 @@ TYPEDEF: void* SEL
TYPEDEF: void* id
FUNCTION: char* sel_getName ( SEL aSelector ) ;
FUNCTION: c-string sel_getName ( SEL aSelector ) ;
FUNCTION: char sel_isMapped ( SEL aSelector ) ;
FUNCTION: SEL sel_registerName ( char* str ) ;
FUNCTION: SEL sel_registerName ( c-string str ) ;
TYPEDEF: void* Class
TYPEDEF: void* Method
@ -33,13 +33,13 @@ CONSTANT: CLS_METHOD_ARRAY HEX: 100
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
FUNCTION: Class objc_getClass ( char* class ) ;
FUNCTION: Class objc_getClass ( c-string class ) ;
FUNCTION: Class objc_getMetaClass ( char* class ) ;
FUNCTION: Class objc_getMetaClass ( c-string class ) ;
FUNCTION: Protocol objc_getProtocol ( char* class ) ;
FUNCTION: Protocol objc_getProtocol ( c-string class ) ;
FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
FUNCTION: Class objc_allocateClassPair ( Class superclass, c-string name, size_t extraBytes ) ;
FUNCTION: void objc_registerClassPair ( Class cls ) ;
FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
@ -54,7 +54,7 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
FUNCTION: Class class_getSuperclass ( Class cls ) ;
FUNCTION: char* class_getName ( Class cls ) ;
FUNCTION: c-string class_getName ( Class cls ) ;
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
@ -64,7 +64,7 @@ FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, c-string* type, int* offset ) ;
FUNCTION: void* method_copyReturnType ( Method method ) ;

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

@ -40,7 +40,7 @@ IN: cocoa.subclassing
: prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip
'[ _ _ "cdecl" _ alien-callback ]
'[ _ _ cdecl _ alien-callback ]
(( -- callback )) define-temp ;
: prepare-methods ( methods -- methods )

13
basis/combinators/smart/smart-tests.factor
View File

@ -63,3 +63,16 @@ IN: combinators.smart.tests
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when ] unit-test
[ 3 ] [ 3 [ even? ] [ 2 + ] smart-when ] unit-test
[ 4 ] [ 2 [ odd? ] [ 2 + ] smart-unless ] unit-test
[ 3 ] [ 3 [ odd? ] [ 2 + ] smart-unless ] unit-test
[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when* ] unit-test
[ ] [ 3 [ even? ] [ 2 + ] smart-when* ] unit-test
[ 3 ] [ 2 [ odd? ] [ 3 ] smart-unless* ] unit-test
[ 3 ] [ 3 [ odd? ] [ 5 ] smart-unless* ] unit-test
[ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
[ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
stack-checker math sequences ;
USING: accessors fry generalizations sequences.generalizations
kernel macros math.order stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
@ -49,8 +49,29 @@ MACRO: preserving ( quot -- )
MACRO: nullary ( quot -- quot' )
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
MACRO: dropping ( quot -- quot' )
inputs '[ [ _ ndrop ] ] ;
MACRO: balancing ( quot -- quot' )
'[ _ [ preserving ] [ dropping ] bi ] ;
MACRO: smart-if ( pred true false -- quot )
'[ _ preserving _ _ if ] ;
MACRO: smart-apply ( quot n -- )
MACRO: smart-when ( pred true -- quot )
'[ _ _ [ ] smart-if ] ;
MACRO: smart-unless ( pred false -- quot )
'[ _ [ ] _ smart-if ] ;
MACRO: smart-if* ( pred true false -- quot )
'[ _ balancing _ swap _ compose if ] ;
MACRO: smart-when* ( pred true -- quot )
'[ _ _ [ ] smart-if* ] ;
MACRO: smart-unless* ( pred false -- quot )
'[ _ [ ] _ smart-if* ] ;
MACRO: smart-apply ( quot n -- quot )
[ dup inputs ] dip '[ _ _ _ mnapply ] ;

4
basis/command-line/command-line-docs.factor
View File

@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"

28
basis/compiler/alien/alien.factor
View File

@ -1,28 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
alien.c-types cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ void* prefix ] when ;
: alien-return ( params -- ctype )
return>> dup large-struct? [ drop void ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
: parameter-offsets ( types -- total offsets )
[
0 [
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;

1
basis/compiler/alien/summary.txt
View File

@ -1 +0,0 @@
Common code used for analysis and code generation of alien bindings

289
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor Normal file
View File

@ -0,0 +1,289 @@
USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test byte-arrays layouts literals alien
accessors sequences ;
IN: compiler.cfg.alias-analysis.tests
: test-alias-analysis ( insn -- insn )
init-alias-analysis
alias-analysis-step
[ f >>insn# ] map ;
! Redundant load elimination
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Store-load forwarding
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Dead store elimination
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 3 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##set-slot-imm f 3 0 1 0 }
} test-alias-analysis
] unit-test
! Redundant store elimination
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 1 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ ##set-slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Not a redundant load
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 0 1 1 0 }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 0 1 1 0 }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Not a redundant store
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 3 1 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 3 1 1 0 }
} test-alias-analysis
] unit-test
! There's a redundant load, but not a redundant store
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##slot f 5 0 3 0 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ ##copy f 6 3 any-rep }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##slot f 5 0 3 0 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ ##slot-imm f 6 0 1 0 }
} test-alias-analysis
] unit-test
! Fresh allocations don't alias existing values
! Redundant load elimination
[
V{
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 3 4 1 0 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##copy f 5 3 any-rep }
}
] [
V{
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 3 4 1 0 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 5 4 1 0 }
} test-alias-analysis
] unit-test
! Redundant store elimination
[
V{
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##slot-imm f 5 1 1 0 }
T{ ##set-slot-imm f 3 4 1 0 }
}
] [
V{
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 1 4 1 0 }
T{ ##slot-imm f 5 1 1 0 }
T{ ##set-slot-imm f 3 4 1 0 }
} test-alias-analysis
] unit-test
! Storing a new alias class into another object means that heap-ac
! can now alias the new ac
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 0 4 1 0 }
T{ ##set-slot-imm f 4 2 1 0 }
T{ ##slot-imm f 5 3 1 0 }
T{ ##set-slot-imm f 1 5 1 0 }
T{ ##slot-imm f 6 4 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##peek f 3 D 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 0 4 1 0 }
T{ ##set-slot-imm f 4 2 1 0 }
T{ ##slot-imm f 5 3 1 0 }
T{ ##set-slot-imm f 1 5 1 0 }
T{ ##slot-imm f 6 4 1 0 }
} test-alias-analysis
] unit-test
! Compares between objects which cannot alias are eliminated
[
V{
T{ ##peek f 0 D 0 }
T{ ##allot f 1 16 array }
T{ ##load-reference f 2 f }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##allot f 1 16 array }
T{ ##compare f 2 0 1 cc= }
} test-alias-analysis
] unit-test
! Make sure that input to ##box-displaced-alien becomes heap-ac
[
V{
T{ ##allot f 1 16 byte-array }
T{ ##load-reference f 2 10 }
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
T{ ##compare f 6 5 1 cc= }
}
] [
V{
T{ ##allot f 1 16 byte-array }
T{ ##load-reference f 2 10 }
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
T{ ##compare f 6 5 1 cc= }
} test-alias-analysis
] unit-test

244
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,17 +1,18 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors words vectors combinators combinators.short-circuit
sets classes layouts cpu.architecture
sets classes layouts fry locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.copy-prop
compiler.cfg.registers
compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
FROM: namespaces => set ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
@ -67,6 +68,14 @@ IN: compiler.cfg.alias-analysis
! e = c
! x[1] = c
! Local copy propagation
SYMBOL: copies
: resolve ( vreg -- vreg ) copies get ?at drop ;
: record-copy ( ##copy -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
! Map vregs -> alias classes
SYMBOL: vregs>acs
@ -84,44 +93,39 @@ SYMBOL: acs>vregs
: ac>vregs ( ac -- vregs ) acs>vregs get at ;
GENERIC: aliases ( vreg -- vregs )
M: integer aliases
: aliases ( vreg -- vregs )
#! All vregs which may contain the same value as vreg.
vreg>ac ac>vregs ;
M: word aliases
1array ;
: each-alias ( vreg quot -- )
[ aliases ] dip each ; inline
: merge-acs ( vreg into -- )
[ vreg>ac ] dip
2dup eq? [ 2drop ] [
[ ac>vregs ] dip
[ vregs>acs get '[ [ _ ] dip _ set-at ] each ]
[ acs>vregs get at push-all ]
2bi
] if ;
! Map vregs -> slot# -> vreg
SYMBOL: live-slots
! Current instruction number
SYMBOL: insn#
! Maps vreg -> slot# -> insn# of last store or f
SYMBOL: recent-stores
! Load/store history, for dead store elimination
TUPLE: load insn# ;
TUPLE: store insn# ;
! A set of insn#s of dead stores
SYMBOL: dead-stores
: new-action ( class -- action )
insn# get swap boa ; inline
: dead-store ( insn# -- ) dead-stores get adjoin ;
! Maps vreg -> slot# -> sequence of loads/stores
SYMBOL: histories
: history ( vreg -- history ) histories get at ;
: set-ac ( vreg ac -- )
:: set-ac ( vreg ac -- )
#! Set alias class of newly-seen vreg.
{
[ drop H{ } clone swap histories get set-at ]
[ drop H{ } clone swap live-slots get set-at ]
[ swap vregs>acs get set-at ]
[ acs>vregs get push-at ]
} 2cleave ;
H{ } clone vreg recent-stores get set-at
H{ } clone vreg live-slots get set-at
ac vreg vregs>acs get set-at
vreg ac acs>vregs get push-at ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
@ -139,20 +143,17 @@ ERROR: vreg-has-no-slots vreg ;
: record-constant-slot ( slot# vreg -- )
#! A load can potentially read every store of this slot#
#! in that alias class.
[
history [ load new-action swap ?push ] change-at
] with each-alias ;
[ recent-stores get at delete-at ] with each-alias ;
: record-computed-slot ( vreg -- )
#! Computed load is like a load of every slot touched so far
[
history values [ load new-action swap push ] each
] each-alias ;
[ recent-stores get at clear-assoc ] each-alias ;
: remember-slot ( value slot#/f vreg -- )
over
[ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
[ 2nip record-computed-slot ] if ;
:: remember-slot ( value slot# vreg -- )
slot# [
slot# vreg record-constant-slot
value slot# vreg load-constant-slot
] [ vreg record-computed-slot ] if ;
SYMBOL: ac-counter
@ -171,106 +172,94 @@ SYMBOL: heap-ac
: kill-constant-set-slot ( slot# vreg -- )
[ live-slots get at delete-at ] with each-alias ;
: record-constant-set-slot ( slot# vreg -- )
history [
dup empty? [ dup last store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
:: record-constant-set-slot ( insn# slot# vreg -- )
vreg recent-stores get at :> recent-stores
slot# recent-stores at [ dead-store ] when*
insn# slot# recent-stores set-at ;
: kill-computed-set-slot ( ac -- )
: kill-computed-set-slot ( vreg -- )
[ live-slots get at clear-assoc ] each-alias ;
: remember-set-slot ( slot#/f vreg -- )
over [
[ record-constant-set-slot ]
[ kill-constant-set-slot ] 2bi
] [ nip kill-computed-set-slot ] if ;
SYMBOL: constants
: constant ( vreg -- n/f )
#! Return a ##load-immediate value, or f if the vreg was not
#! assigned by an ##load-immediate.
resolve constants get at ;
:: remember-set-slot ( insn# slot# vreg -- )
slot# [
insn# slot# vreg record-constant-set-slot
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: ##slot insn-slot# slot>> constant ;
M: ##slot insn-slot# drop f ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot insn-slot# drop f ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field-ptr insn-slot# field-name>> ;
M: ##vm-field insn-slot# offset>> ;
M: ##set-vm-field insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
M: ##vm-field insn-object drop \ ##vm-field ;
M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
GENERIC: analyze-aliases ( insn -- insn' )
0 ac-counter set
next-ac heap-ac set
M: insn analyze-aliases ;
\ ##vm-field-ptr set-new-ac
\ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: insn analyze-aliases*
M: vreg-insn analyze-aliases
! If an instruction defines a value with a non-integer
! representation it means that the value will be boxed
! anywhere its used as a tagged pointer. Boxing allocates
! a new value, except boxing instructions haven't been
! inserted yet.
dup defs-vreg [
over defs-vreg-rep int-rep eq?
over defs-vreg-rep { int-rep tagged-rep } member?
[ set-heap-ac ] [ set-new-ac ] if
] when* ;
M: ##phi analyze-aliases*
M: ##phi analyze-aliases
dup defs-vreg set-heap-ac ;
M: ##load-immediate analyze-aliases*
call-next-method
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: ##allocation analyze-aliases*
M: ##allocation analyze-aliases
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##read analyze-aliases*
M: ##box-displaced-alien analyze-aliases
[ call-next-method ]
[ base>> heap-ac get merge-acs ] bi ;
M: ##read analyze-aliases
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip any-rep \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
2dup live-slot dup
[ 2nip <copy> analyze-aliases nip ]
[ drop remember-slot ]
if ;
: idempotent? ( value slot#/f vreg -- ? )
#! Are we storing a value back to the same slot it was read
#! from?
live-slot = ;
M: ##write analyze-aliases*
dup
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
[ remember-set-slot drop ] [ load-slot ] 3bi ;
M:: ##write analyze-aliases ( insn -- insn )
insn src>> resolve :> src
insn insn-slot# :> slot#
insn insn-object :> vreg
insn insn#>> :> insn#
M: ##copy analyze-aliases*
src slot# vreg idempotent? [ insn# dead-store ] [
src heap-ac get merge-acs
insn insn#>> slot# vreg remember-set-slot
src slot# vreg load-slot
] if
insn ;
M: ##copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup record-copy ;
@ -281,48 +270,47 @@ M: ##copy analyze-aliases*
[ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ]
} 1&& ; inline
M: ##compare analyze-aliases*
M: ##compare analyze-aliases
call-next-method
dup useless-compare? [
dst>> \ f type-number \ ##load-immediate new-insn
analyze-aliases*
dst>> f \ ##load-reference new-insn
analyze-aliases
] when ;
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
GENERIC: eliminate-dead-stores ( insn -- ? )
SYMBOL: live-stores
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
: compute-live-stores ( -- )
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
] map concat unique
live-stores set ;
M: insn eliminate-dead-stores drop t ;
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
drop f
] unless
] when ;
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
acs>vregs get clear-assoc
live-slots get clear-assoc
copies get clear-assoc
dead-stores get table>> clear-assoc
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
next-ac heap-ac set
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
: alias-analysis-step ( insns -- insns' )
init-alias-analysis
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
[ 0 [ [ insn#<< ] [ drop 1 + ] 2bi ] reduce drop ]
[ [ analyze-aliases ] map! [ eliminate-dead-stores ] filter! ] tri ;
: alias-analysis ( cfg -- cfg' )
[ alias-analysis-step ] local-optimization ;
: alias-analysis ( cfg -- cfg )
init-alias-analysis
dup [ alias-analysis-step ] simple-optimization ;

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

@ -10,9 +10,9 @@ IN: compiler.cfg.block-joining
! before stack analysis.
: join-block? ( bb -- ? )
{
[ kill-block? not ]
[ kill-block?>> not ]
[ predecessors>> length 1 = ]
[ predecessor kill-block? not ]
[ predecessor kill-block?>> not ]
[ predecessor successors>> length 1 = ]
[ [ predecessor ] keep back-edge? not ]
} 1&& ;
@ -21,7 +21,7 @@ IN: compiler.cfg.block-joining
[ instructions>> ] bi@ dup pop* push-all ;
: update-successors ( bb pred -- )
[ successors>> ] dip (>>successors) ;
[ successors>> ] dip successors<< ;
: join-block ( bb pred -- )
[ join-instructions ] [ update-successors ] 2bi ;

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

@ -1,9 +1,10 @@
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math math.order
sequences assocs namespaces vectors fry arrays splitting
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
USING: accessors combinators combinators.short-circuit kernel
math math.order sequences assocs namespaces vectors fry arrays
splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
: clone-instructions ( insns -- insns' )
@ -15,10 +16,12 @@ IN: compiler.cfg.branch-splitting
! 'back-edge?' work.
<basic-block>
swap
[ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ]
[ number>> >>number ]
tri ;
{
[ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ]
[ kill-block?>> >>kill-block? ]
[ number>> >>number ]
} cleave ;
: new-blocks ( bb -- copies )
dup predecessors>> [

110
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,73 +1,77 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture layouts
USING: namespaces accessors math math.order assocs kernel
sequences combinators classes words system fry locals
cpu.architecture layouts compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
SYMBOLS: param-area-size allot-area-size allot-area-align
frame-required? ;
: frame-required ( -- ) frame-required? on ;
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
frame-required? on
stack-frame [ max-stack-frame ] change ;
M:: ##local-allot compute-stack-frame* ( insn -- )
frame-required
insn size>> :> s
insn align>> :> a
allot-area-align [ a max ] change
allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
##alien-assembly
##alien-callback ;
M: ##stack-frame compute-stack-frame*
frame-required
stack-frame>> param-area-size [ max ] change ;
M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
: vm-frame-required ( -- )
frame-required
vm-stack-space param-area-size [ max ] change ;
M: ##call compute-stack-frame* drop frame-required? on ;
M: ##call-gc compute-stack-frame* drop vm-frame-required ;
M: ##box compute-stack-frame* drop vm-frame-required ;
M: ##unbox compute-stack-frame* drop vm-frame-required ;
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
M: ##end-callback compute-stack-frame* drop vm-frame-required ;
M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##gc compute-stack-frame*
frame-required? on
stack-frame new
swap tagged-values>> length cells >>gc-root-size
t >>calls-vm?
request-stack-frame ;
M: ##call compute-stack-frame* drop frame-required ;
M: ##alien-callback compute-stack-frame* drop frame-required ;
M: ##spill compute-stack-frame* drop frame-required ;
M: ##reload compute-stack-frame* drop frame-required ;
M: _spill-area-size compute-stack-frame*
n>> stack-frame get (>>spill-area-size) ;
M: ##float>integer compute-stack-frame*
drop integer-float-needs-stack-frame? [ frame-required ] when ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
M: ##integer>float compute-stack-frame*
drop integer-float-needs-stack-frame? [ frame-required ] when ;
\ _spill t frame-required? set-word-prop
\ ##unary-float-function t frame-required? set-word-prop
\ ##binary-float-function t frame-required? set-word-prop
M: insn compute-stack-frame* drop ;
: compute-stack-frame ( insns -- )
frame-required? off
stack-frame new stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
: finalize-stack-frame ( stack-frame -- )
dup [ params>> ] [ allot-area-align>> ] bi align >>allot-area-base
dup [ [ allot-area-base>> ] [ allot-area-size>> ] bi + ] [ spill-area-align>> ] bi align >>spill-area-base
dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
: <stack-frame> ( cfg -- stack-frame )
[ stack-frame new ] dip
[ spill-area-size>> >>spill-area-size ]
[ spill-area-align>> >>spill-area-align ] bi
allot-area-size get >>allot-area-size
allot-area-align get >>allot-area-align
param-area-size get >>params
dup finalize-stack-frame ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
: compute-stack-frame ( cfg -- stack-frame/f )
[ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ]
[ frame-required? get [ <stack-frame> ] [ drop f ] if ]
bi ;
M: ##epilogue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
: insert-pro/epilogues ( insns -- insns )
[ [ insert-pro/epilogues* ] each ] { } make ;
: build-stack-frame ( mr -- mr )
[
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
] with-scope ;
: build-stack-frame ( cfg -- cfg )
0 param-area-size set
0 allot-area-size set
cell allot-area-align set
dup compute-stack-frame >>stack-frame ;

198
basis/compiler/cfg/builder/alien/alien.factor Normal file
View File

@ -0,0 +1,198 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays layouts math math.order math.parser
combinators combinators.short-circuit fry make sequences
sequences.generalizations alien alien.private alien.strings
alien.c-types alien.libraries classes.struct namespaces kernel
strings libc locals quotations words cpu.architecture
compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
[ length neg ##inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
heap-size cell f ^^local-allot [
'[ _ prefix ]
[ int-rep struct-return-on-stack? 2array prefix ] bi*
] keep
] [ drop f ] if ;
: caller-parameter ( vreg rep on-stack? -- insn )
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
if ;
: (caller-parameters) ( vregs reps -- )
! Place ##store-stack-param instructions first. This ensures
! that no registers are used after the ##store-reg-param
! instructions.
[ first2 caller-parameter ] 2map
[ ##store-stack-param? ] partition [ % ] bi@ ;
: caller-parameters ( params -- stack-size )
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-caller struct-return-area set
(caller-parameters)
stack-params get
struct-return-area get
] with-param-regs
struct-return-area set ;
: box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
M: string dlsym-valid? dlsym ;
M: array dlsym-valid? '[ _ dlsym ] any? ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd dlsym-valid?
[ drop ] [ cfg get word>> no-such-symbol ] if
] [ dll-path cfg get word>> no-such-library drop ] if ;
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-block ( node quot: ( params -- ) -- )
'[
make-kill-block
params>>
_ [ alien-node-height ] bi
] emit-trivial-block ; inline
: emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ]
2bi ;
M: #alien-invoke emit-node
[
{
[ caller-parameters ]
[ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
[ caller-parameters src ##alien-indirect ]
[ emit-stack-frame ]
[ box-return* ]
tri
] emit-alien-block ;
M: #alien-assembly emit-node
[
{
[ caller-parameters ]
[ quot>> ##alien-assembly ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
: callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
if ;
: prepare-struct-callee ( c-type -- vreg )
large-struct?
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
: (callee-parameters) ( params -- vregs reps )
[ flatten-parameter-type ] map
[
[ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
concat [ ##load-reg-param? ] partition [ % ] bi@
]
[ [ keys ] map ]
bi ;
: box-parameters ( vregs reps params -- )
##begin-callback
next-vreg next-vreg ##restore-context
[
next-vreg next-vreg ##save-context
box-parameter
1 ##inc-d D 0 ##replace
] 3each ;
: callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri
'[
_ prepare-struct-callee struct-return-area set
_ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
stack-params get
struct-return-area get
] with-param-regs
struct-return-area set ;
: callback-stack-cleanup ( stack-size params -- )
[ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
"stack-cleanup" set-word-prop ;
: needs-frame-pointer ( -- )
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
needs-frame-pointer
##prologue
[
{
[ callee-parameters ]
[ quot>> ##alien-callback ]
[
return>> [ ##end-callback ] [
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
] if-void
]
[ callback-stack-cleanup ]
} cleave
] emit-alien-block
##epilogue
##return
] with-cfg-builder ;

1
basis/compiler/cfg/builder/alien/boxing/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

145
basis/compiler/cfg/builder/alien/boxing/boxing.factor Normal file
View File

@ -0,0 +1,145 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs classes.struct fry
kernel layouts locals math namespaces sequences
sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
! pairs have shape { rep on-stack? }
GENERIC: flatten-c-type ( c-type -- pairs )
M: c-type flatten-c-type
rep>> f 2array 1array ;
M: long-long-type flatten-c-type
drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
HOOK: flatten-struct-type cpu ( type -- pairs )
M: object flatten-struct-type
heap-size cell align cell /i { int-rep f } <repetition> ;
M: struct-c-type flatten-c-type
flatten-struct-type ;
: stack-size ( c-type -- n )
base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
: component-offsets ( reps -- offsets )
0 [ rep-size + ] accumulate nip ;
:: explode-struct ( src c-type -- vregs reps )
c-type flatten-struct-type :> reps
reps keys dup component-offsets
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
reps ;
:: implode-struct ( src vregs reps -- )
vregs reps dup component-offsets
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
GENERIC: unbox ( src c-type -- vregs reps )
M: c-type unbox
[ unboxer>> ] [ rep>> ] bi
[ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
M: long-long-type unbox
[ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
int-rep long-long-on-stack? 2array dup 2array ;
M: struct-c-type unbox ( src c-type -- vregs )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )
dup value-struct? [ drop void* base-type ] unless ;
GENERIC: unbox-parameter ( src c-type -- vregs reps )
M: c-type unbox-parameter unbox ;
M: long-long-type unbox-parameter unbox ;
M: struct-c-type unbox-parameter
dup value-struct? [ unbox ] [
[ nip heap-size cell f ^^local-allot dup ]
[ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
implode-struct
1array { { int-rep f } }
] if ;
GENERIC: unbox-return ( src c-type -- )
: store-return ( vregs reps -- )
[
[ [ next-return-reg ] keep ##store-reg-param ] 2each
] with-return-regs ;
: (unbox-return) ( src c-type -- vregs reps )
! Don't care about on-stack? flag when looking at return
! values.
unbox keys ;
M: c-type unbox-return (unbox-return) store-return ;
M: long-long-type unbox-return (unbox-return) store-return ;
M: struct-c-type unbox-return
dup return-struct-in-registers?
[ (unbox-return) store-return ]
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
GENERIC: flatten-parameter-type ( c-type -- reps )
M: c-type flatten-parameter-type flatten-c-type ;
M: long-long-type flatten-parameter-type flatten-c-type ;
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
[ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
M: long-long-type box
[ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
M: struct-c-type box
'[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
M: c-type box-parameter box ;
M: long-long-type box-parameter box ;
M: struct-c-type box-parameter
dup value-struct?
[ [ [ drop first ] dip explode-struct keys ] keep ] unless
box ;
GENERIC: box-return ( c-type -- dst )
: load-return ( c-type -- vregs reps )
[
flatten-c-type keys
[ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
] with-return-regs ;
M: c-type box-return [ load-return ] keep box ;
M: long-long-type box-return [ load-return ] keep box ;
M: struct-c-type box-return
[
dup return-struct-in-registers?
[ load-return ]
[ [ struct-return-area get ] dip explode-struct keys ] if
] keep box ;

1
basis/compiler/cfg/builder/alien/params/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

53
basis/compiler/cfg/builder/alien/params/params.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order
namespaces sequences vectors assocs ;
IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
: alloc-stack-param ( rep -- n )
stack-params get
[ rep-size cell align stack-params +@ ] dip ;
: ?dummy-stack-params ( rep -- )
dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
: ?dummy-int-params ( rep -- )
dummy-int-params? [
rep-size cell /i 1 max
[ int-regs get [ pop* ] unless-empty ] times
] [ drop ] if ;
: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
GENERIC: next-reg-param ( rep -- reg )
M: int-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi
int-regs get pop ;
M: float-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
M: double-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
: reg-class-full? ( reg-class -- ? ) get empty? ;
: init-reg-class ( abi reg-class -- )
[ swap param-regs at <reversed> >vector ] keep set ;
: init-regs ( regs -- )
[ <reversed> >vector swap set ] assoc-each ;
: with-param-regs ( abi quot -- )
'[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
: with-return-regs ( quot -- )
'[ return-regs init-regs @ ] with-scope ; inline

8
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel make math namespaces sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
@ -31,6 +31,9 @@ IN: compiler.cfg.builder.blocks
call
##branch begin-basic-block ; inline
: make-kill-block ( -- )
basic-block get t >>kill-block? drop ;
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
@ -38,6 +41,7 @@ IN: compiler.cfg.builder.blocks
[
[ word>> ##call ]
[ call-height adjust-d ] bi
make-kill-block
] emit-trivial-block ;
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
@ -66,7 +70,7 @@ IN: compiler.cfg.builder.blocks
[ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
: emit-conditional ( branches -- )
! branchies is a sequence of pairs as above
! branches is a sequence of pairs as above
end-basic-block
[ merge-heights begin-basic-block ]
[ set-successors ]

72
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -1,17 +1,19 @@
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
prettyprint alien alien.accessors math.private
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.rpo
compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
arrays locals byte-arrays kernel.private math slots.private
vectors sbufs strings math.partial-dispatch hashtables assocs
combinators.short-circuit strings.private accessors
compiler.cfg.instructions compiler.cfg.representations ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
'[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: unit-test-builder ( quot -- )
'[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
@ -68,8 +70,8 @@ IN: compiler.cfg.builder.tests
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ int f "malloc" { int } alien-invoke ]
[ int { int } "cdecl" alien-indirect ]
[ int { int } "cdecl" [ ] alien-callback ]
[ int { int } cdecl alien-indirect ]
[ int { int } cdecl [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
@ -104,7 +106,7 @@ IN: compiler.cfg.builder.tests
set-string-nth-fast
]
} [
unit-test-cfg
unit-test-builder
] each
: test-1 ( -- ) test-1 ;
@ -115,7 +117,7 @@ IN: compiler.cfg.builder.tests
test-1
test-2
test-3
} [ unit-test-cfg ] each
} [ unit-test-builder ] each
{
byte-array
@ -133,8 +135,8 @@ IN: compiler.cfg.builder.tests
alien-float
alien-double
} [| word |
{ class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ class fixnum } word '[ _ declare _ execute ] unit-test-cfg
{ class } word '[ _ declare 10 _ execute ] unit-test-builder
{ class fixnum } word '[ _ declare _ execute ] unit-test-builder
] each
{
@ -145,23 +147,23 @@ IN: compiler.cfg.builder.tests
set-alien-unsigned-2
set-alien-unsigned-4
} [| word |
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
] each
{ float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
{ float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
{ float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
{ float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
{ float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
{ float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
] each
: count-insns ( quot insn-check -- ? )
[ test-mr [ instructions>> ] map ] dip
'[ _ count ] map-sum ; inline
[ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
count ; inline
: contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline
@ -172,17 +174,29 @@ IN: compiler.cfg.builder.tests
[ t ] [
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ t ] [
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
[ ##set-alien-integer-1? ] contains-insn?
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
] unit-test
[ t t ] [
[ { byte-array fixnum } declare alien-cell ]
[ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
[ [ ##box-alien? ] contains-insn? ]
bi
] unit-test
[ f ] [
[ { byte-array integer } declare alien-cell ]
[ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
] unit-test
[ f ] [
@ -209,7 +223,7 @@ IN: compiler.cfg.builder.tests
[ [ ##allot? ] contains-insn? ] bi
] unit-test
[ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
[ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
] when
! Regression. Make sure everything is inlined correctly

67
basis/compiler/cfg/builder/builder.factor
View File

@ -19,8 +19,7 @@ compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
compiler.cfg.stacks.local
compiler.alien ;
compiler.cfg.stacks.local ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
@ -57,6 +56,7 @@ GENERIC: emit-node ( node -- )
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
make-kill-block
##prologue
##branch
begin-basic-block ;
@ -82,8 +82,12 @@ GENERIC: emit-node ( node -- )
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
[ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
if ;
[
[
[ ##call ] [ adjust-d ] bi*
make-kill-block
] emit-trivial-block
] if ;
! #recursive
: recursive-height ( #recursive -- n )
@ -123,7 +127,7 @@ M: #recursive emit-node
and ;
: emit-trivial-if ( -- )
ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
[ f cc/= ^^compare-imm ] unary-op ;
: trivial-not-if? ( #if -- ? )
children>> first2
@ -132,12 +136,12 @@ M: #recursive emit-node
and ;
: emit-trivial-not-if ( -- )
ds-pop \ f type-number cc= ^^compare-imm ds-push ;
[ f cc= ^^compare-imm ] unary-op ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
@ -195,7 +199,11 @@ M: #shuffle emit-node
! #return
: emit-return ( -- )
##branch begin-basic-block ##epilogue ##return ;
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
M: #return emit-node drop emit-return ;
@ -205,49 +213,6 @@ M: #return-recursive emit-node
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
! FFI
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
{
{ [ dup c-struct? not ] [ drop 0 ] }
{ [ dup large-struct? not ] [ drop 2 cells ] }
[ heap-size ]
} cond ;
: <alien-stack-frame> ( params -- stack-frame )
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-offsets drop >>params ] bi
t >>calls-vm? ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-node ( node quot -- )
[
[ params>> dup dup <alien-stack-frame> ] dip call
alien-node-height
] emit-trivial-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-assembly emit-node
[ ##alien-assembly ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
[ ##alien-callback ] emit-alien-node
##epilogue
##return
] with-cfg-builder ;
! No-op nodes
M: #introduce emit-node drop ;

20
basis/compiler/cfg/cfg.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
@ -8,7 +8,9 @@ TUPLE: basic-block < identity-tuple
number
{ instructions vector }
{ successors vector }
{ predecessors vector } ;
{ predecessors vector }
{ kill-block? boolean }
{ unlikely? boolean } ;
: <basic-block> ( -- bb )
basic-block new
@ -20,7 +22,9 @@ number
M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
spill-area-size reps
spill-area-size spill-area-align
stack-frame
frame-pointer?
post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ;
@ -39,13 +43,5 @@ predecessors-valid? dominance-valid? loops-valid? ;
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
: with-cfg ( cfg quot: ( cfg -- ) -- )
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )
mr new
swap >>label
swap >>word
swap >>instructions ;

63
basis/compiler/cfg/checker/checker.factor
View File

@ -3,72 +3,15 @@
USING: kernel combinators.short-circuit accessors math sequences
sets assocs compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization
compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
compiler.cfg.utilities compiler.cfg.finalization
compiler.utilities ;
IN: compiler.cfg.checker
! Check invariants
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
dup instructions>> dup penultimate ##epilogue? [
{
[ length 2 = ]
[ last { [ ##return? ] [ ##jump? ] } 1|| ]
} 1&&
] [ last ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
: check-last-instruction ( bb -- )
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
[ ##compare-branch? ]
[ ##compare-imm-branch? ]
[ ##compare-float-ordered-branch? ]
[ ##compare-float-unordered-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-kill-insn bb ;
: check-kill-instructions ( bb -- )
dup instructions>> [ kill-vreg-insn? ] any?
[ bad-kill-insn ] [ drop ] if ;
: check-normal-block ( bb -- )
[ check-last-instruction ]
[ check-kill-instructions ]
bi ;
ERROR: bad-successors ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> member-eq? ] with all?
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
[ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
[ check-successors ]
bi ;
ERROR: bad-live-in ;
ERROR: undefined-values uses defs ;
: check-mr ( mr -- )
! Check that every used register has a definition
instructions>>
[ [ uses-vregs ] map concat ]
[ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- )
[ [ check-basic-block ] each-basic-block ]
[ build-mr check-mr ]
bi ;
[ check-successors ] each-basic-block ;

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

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
@ -12,6 +12,8 @@ SYMBOLS:
SYMBOLS:
vcc-all vcc-notall vcc-any vcc-none ;
SYMBOLS: cc-o cc/o ;
: negate-cc ( cc -- cc' )
H{
{ cc< cc/< }
@ -28,6 +30,8 @@ SYMBOLS:
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/<>= cc<>= }
{ cc-o cc/o }
{ cc/o cc-o }
} at ;
: negate-vcc ( cc -- cc' )

107
basis/compiler/cfg/copy-prop/copy-prop-tests.factor Normal file
View File

@ -0,0 +1,107 @@
USING: compiler.cfg.copy-prop tools.test namespaces kernel
compiler.cfg.debugger compiler.cfg accessors
compiler.cfg.registers compiler.cfg.instructions
cpu.architecture ;
IN: compiler.cfg.copy-prop.tests
: test-copy-propagation ( -- )
cfg new 0 get >>entry copy-propagation drop ;
! Simple example
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
T{ ##peek f 1 D 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##copy f 2 0 any-rep }
T{ ##branch }
} 3 test-bb
V{
T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
T{ ##branch }
} 4 test-bb
V{
T{ ##copy f 6 4 any-rep }
T{ ##replace f 3 D 0 }
T{ ##replace f 5 D 1 }
T{ ##replace f 6 D 2 }
T{ ##branch }
} 5 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 6 test-bb
0 1 edge
1 { 2 3 } edges
2 4 edge
3 4 edge
4 5 edge
[ ] [ test-copy-propagation ] unit-test
[
V{
T{ ##replace f 0 D 0 }
T{ ##replace f 4 D 1 }
T{ ##replace f 4 D 2 }
T{ ##branch }
}
] [ 5 get instructions>> ] unit-test
! Test optimistic assumption
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
T{ ##copy f 2 1 any-rep }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f 2 D 1 }
T{ ##branch }
} 3 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 4 test-bb
0 1 edge
1 2 edge
2 { 2 3 } edges
3 4 edge
[ ] [ test-copy-propagation ] unit-test
[
V{
T{ ##replace f 0 D 1 }
T{ ##branch }
}
] [ 3 get instructions>> ] unit-test

100
basis/compiler/cfg/copy-prop/copy-prop.factor
View File

@ -1,78 +1,90 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors sequences grouping
combinators compiler.cfg.rpo compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.predecessors ;
USING: sets kernel namespaces assocs accessors sequences grouping
combinators fry compiler.cfg.def-use compiler.cfg.rpo
compiler.cfg.renaming compiler.cfg.instructions
compiler.cfg.predecessors ;
FROM: namespaces => set ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
SYMBOL: copies
! Initialized per-basic-block; a mapping from inputs to dst for eliminating
! redundant phi instructions
SYMBOL: phis
: resolve ( vreg -- vreg )
copies get ?at drop ;
: (record-copy) ( dst src -- )
swap copies get set-at ; inline
: record-copy ( ##copy -- )
[ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
<PRIVATE
SYMBOL: changed?
SYMBOL: copies
! Initialized per-basic-block; a mapping from inputs to dst for
! eliminating redundant ##phi instructions
SYMBOL: phis
: resolve ( vreg -- vreg )
copies get at ;
: record-copy ( dst src -- )
swap copies get maybe-set-at [ changed? on ] when ; inline
GENERIC: visit-insn ( insn -- )
M: ##copy visit-insn record-copy ;
M: ##copy visit-insn
[ dst>> ] [ src>> resolve ] bi
dup [ record-copy ] [ 2drop ] if ;
: useless-phi ( dst inputs -- ) first (record-copy) ;
: useless-phi ( dst inputs -- ) first record-copy ;
: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
: redundant-phi ( dst inputs -- ) phis get at record-copy ;
: record-phi ( dst inputs -- ) phis get set-at ;
: record-phi ( dst inputs -- )
[ phis get set-at ] [ drop dup record-copy ] 2bi ;
M: ##phi visit-insn
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
{
{ [ dup all-equal? ] [ useless-phi ] }
{ [ dup phis get key? ] [ redundant-phi ] }
[ record-phi ]
} cond ;
dup phis get key? [ redundant-phi ] [
dup sift
dup all-equal?
[ nip useless-phi ]
[ drop record-phi ] if
] if ;
M: vreg-insn visit-insn
defs-vreg [ dup record-copy ] when* ;
M: insn visit-insn drop ;
: collect-copies ( cfg -- )
H{ } clone copies set
: (collect-copies) ( cfg -- )
[
H{ } clone phis set
phis get clear-assoc
instructions>> [ visit-insn ] each
] each-basic-block ;
: collect-copies ( cfg -- )
H{ } clone copies set
H{ } clone phis set
'[
changed? off
_ (collect-copies)
changed? get
] loop ;
GENERIC: update-insn ( insn -- keep? )
M: ##copy update-insn drop f ;
M: ##phi update-insn
dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
dup call-next-method drop
[ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
M: insn update-insn rename-insn-uses t ;
M: vreg-insn update-insn rename-insn-uses t ;
M: insn update-insn drop t ;
: rename-copies ( cfg -- )
copies get dup assoc-empty? [ 2drop ] [
renamings set
[
instructions>> [ update-insn ] filter! drop
] each-basic-block
] if ;
copies get renamings set
[ [ update-insn ] filter! ] simple-optimization ;
PRIVATE>
: copy-propagation ( cfg -- cfg' )
needs-predecessors
[ collect-copies ]
[ rename-copies ]
[ ]
tri ;
dup collect-copies
dup rename-copies ;

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

@ -18,27 +18,21 @@ MIXIN: dataflow-analysis
: <dfa-worklist> ( cfg dfa -- queue )
block-order <hashed-dlist> [ push-all-front ] keep ;
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
:: compute-in-set ( bb out-sets dfa -- set )
! Only consider initialized sets.
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets ;
bb kill-block?>> [ f ] [
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets
] if ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
bb in-sets maybe-set-at ; inline
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-out-set 3drop f ;
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
bb in-sets at bb dfa transfer-set ;
:: compute-out-set ( bb in-sets dfa -- set )
bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
:: update-out-set ( bb in-sets out-sets dfa -- ? )
bb in-sets dfa compute-out-set

24
basis/compiler/cfg/dce/dce-tests.factor
View File

@ -11,41 +11,41 @@ IN: compiler.cfg.dce.tests
entry>> instructions>> ;
[ V{
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} ] [ V{
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc D 0 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst 1 } { val 8 } }
T{ ##load-immediate { dst 2 } { val 16 } }
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
} test-dce ] unit-test
[ V{ } ] [ V{
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test
[ V{
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
} ] [ V{
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc D 0 } }
@ -62,11 +62,11 @@ IN: compiler.cfg.dce.tests
[ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} ] [ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc D 0 } }
T{ ##load-immediate { dst 3 } { val 8 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
} test-dce ] unit-test

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