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

.gitignore

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

Factor.app/Contents/Info.plist

@@ -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>

GNUmakefile

@@ -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)
+factor-lib: $(ENGINE)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+
+factor: $(EXE_OBJS) $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
 
-factor-console: $(EXE_OBJS) $(ENGINE)
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(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

Nmakefile

@@ -1,15 +1,31 @@
-!IF DEFINED(DEBUG)
+!IF !DEFINED(BOOTIMAGE_VERSION)
-LINK_FLAGS = /nologo /DEBUG shell32.lib
+BOOTIMAGE_VERSION = latest
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
-!ELSE
-LINK_FLAGS = /nologo shell32.lib
-CL_FLAGS = /nologo /O2 /W3
 !ENDIF
 
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+!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)
+factor.com: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
 
-factor.exe: $(EXE_OBJS)
+factor.exe: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_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
+	if exist factor.lib del factor.lib
-	del factor.com
+	if exist factor.com del factor.com
-	del factor.exe
+	if exist factor.exe del factor.exe
-	del factor.dll
+	if exist factor.dll del factor.dll
-	del factor.dll.lib
+	if exist factor.dll.lib del factor.dll.lib
 
-.PHONY: all clean
+.PHONY: all default x86-32 x86-64 clean
 
 .SUFFIXES: .rs

basis/alarms/alarms-docs.factor

@@ -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
+HELP: start-alarm
-{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
-}
-{ $examples
-    { $unchecked-example
-        """USING: alarms calendar io threads ;"""
-        """["""
-        """    "Hi, this should only get printed once..." print flush"""
-        """    current-alarm get cancel-alarm"""
-        """] 1 seconds every"""
-        ""
-    }
-} ;
-
-HELP: add-alarm
-{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
-{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
-
-HELP: later
-{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
-{ $examples
-    { $unchecked-example
-        "USING: alarms io calendar ;"
-        """[ "Break's over!" print flush ] 15 minutes drop"""
-        ""
-    }
-} ;
-
-HELP: cancel-alarm
 { $values { "alarm" alarm } }
-{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
+{ $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:"
+"A recurring alarm with an initial delay:"
-{ $subsections current-alarm }
+{ $subsections delayed-every } ;
-"Low-level interface to add alarms:"
-{ $subsections add-alarm }
-"Cancelling an alarm:"
-{ $subsections cancel-alarm }
-"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
 
 ABOUT: "alarms"

basis/alarms/alarms-tests.factor

@@ -1,17 +1,67 @@
-USING: alarms alarms.private kernel calendar sequences
+USING: alarms alarms.private calendar concurrency.count-downs
-tools.test threads 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
 
 [ ] [
-    [
+    self [ resume ] curry instant later drop
-        [ resume ] curry instant later drop
+    "test" suspend 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

basis/alarms/alarms.factor

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

basis/alien/arrays/arrays.factor

@@ -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 base-type drop void* base-type ;
-
-M: array unbox-parameter drop void* unbox-parameter ;
-
-M: array unbox-return drop void* unbox-return ;
-
-M: array box-parameter drop void* box-parameter ;
-
-M: array box-return drop void* box-return ;
-
-M: array stack-size drop void* stack-size ;
-
-M: array c-type-boxer-quot
-    unclip
-    [ array-length ]
-    [ [ require-c-array ] keep ] bi*
-    [ <c-direct-array> ] 2curry ;
-
-M: array c-type-unboxer-quot drop [ >c-ptr ] ;
 
 PREDICATE: string-type < pair
-    first2 [ char* = ] [ word? ] bi* and ;
+    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
+M: string-type heap-size drop void* heap-size ;
-    drop void* heap-size ;
 
-M: string-type c-type-align
+M: string-type c-type-align drop void* c-type-align ;
-    drop void* c-type-align ;
 
-M: string-type c-type-align-first
+M: string-type c-type-align-first drop void* c-type-align-first ;
-    drop void* c-type-align-first ;
 
-M: string-type c-type-stack-align?
+M: string-type base-type drop void* base-type ;
-    drop void* c-type-stack-align? ;
 
-M: string-type unbox-parameter
+M: string-type c-type-rep drop int-rep ;
-    drop void* unbox-parameter ;
-
-M: string-type unbox-return
-    drop void* unbox-return ;
-
-M: string-type box-parameter
-    drop void* box-parameter ;
-
-M: string-type box-return
-    drop void* box-return ;
-
-M: string-type stack-size
-    drop void* stack-size ;
-
-M: string-type c-type-rep
-    drop int-rep ;
-
-M: string-type c-type-boxer
-    drop void* c-type-boxer ;
-
-M: string-type c-type-unboxer
-    drop void* c-type-unboxer ;
 
 M: string-type c-type-boxer-quot
-    second '[ _ alien>string ] ;
+    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
+[ { c-string utf8 } c-string typedef ] with-compilation-unit
-char* uchar* typedef
 
-char char* "pointer-c-type" set-word-prop
-uchar uchar* "pointer-c-type" set-word-prop

basis/alien/c-types/c-types-docs.factor

@@ -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
+HELP: alien-value
-{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
+{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
-{ $description "Outputs a quotation which reads values of this C type from a C structure." }
+{ $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
+HELP: set-alien-value
-{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
+{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
-{ $description "Outputs a quotation which writes values of this C type to a C structure." }
+{ $description "Stores a value at a byte offset from a base C pointer." }
-{ $errors "Throws an error if the type does not exist." } ;
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
-
-HELP: box-parameter
-{ $values { "n" math:integer } { "c-type" "a C type" } }
-{ $description "Generates code for converting a C value stored at  offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
-{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
-
-HELP: box-return
-{ $values { "c-type" "a C type" } }
-{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
-{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
-
-HELP: unbox-return
-{ $values { "c-type" "a C type" } }
-{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
-{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
 
 HELP: define-deref
 { $values { "c-type" "a C type" } }
@@ -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." } ;
+{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
-HELP: char*
+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

basis/alien/c-types/c-types-tests.factor

@@ -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 ] [ pointer: void c-type void* c-type = ] unit-test
-[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] 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 ] [ int   c-type          MyInt c-type = ] unit-test
-[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
-
-TYPEDEF: char MyChar
-
-[ t ] [ char  c-type MyChar                      c-type eq? ] unit-test
-[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
-[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
 
 [ 32 ] [ { int 8 } heap-size ] unit-test
 
-TYPEDEF: char* MyString
+TYPEDEF: char MyChar
 
-[ t ] [ char* c-type MyString                      c-type eq? ] unit-test
+[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
-[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] 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
+[ t ] [ void* c-type MyIntArray c-type = ] unit-test
-
-TYPEDEF: uchar* MyLPBYTE
-
-[ t ] [ { char* utf8 } c-type MyLPBYTE 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
 
 [ """

basis/alien/c-types/c-types.factor

@@ -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 }
+{ rep initial: int-rep } ;
-stack-align? ;
 
 : <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
+UNION: c-type-name
-    dup "pointer-c-type" word-prop
+    c-type-word pointer ;
-    [ ] [ drop void* ] ?if ;
-
-M: array resolve-pointer-type
-    first resolve-pointer-type ;
 
 : 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 ) foldable
-
-GENERIC: c-type-align ( name -- n )
 
 M: abstract-c-type c-type-align align>> ;
 
-M: c-type-name c-type-align c-type c-type-align ;
-
 GENERIC: c-type-align-first ( name -- n )
 
-M: c-type-name c-type-align-first c-type c-type-align-first ;
-
 M: abstract-c-type c-type-align-first align-first>> ;
 
-GENERIC: c-type-stack-align? ( name -- ? )
+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? ;
+M: c-type base-type ;
-
-: c-type-box ( n c-type -- )
-    [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
-    %box ;
-
-: c-type-unbox ( n c-type -- )
-    [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
-    %unbox ;
-
-GENERIC: box-parameter ( n c-type -- )
-
-M: c-type box-parameter c-type-box ;
-
-M: c-type-name box-parameter c-type box-parameter ;
-
-GENERIC: box-return ( c-type -- )
-
-M: c-type box-return f swap c-type-box ;
-
-M: c-type-name box-return c-type box-return ;
-
-GENERIC: unbox-parameter ( n c-type -- )
-
-M: c-type unbox-parameter c-type-unbox ;
-
-M: c-type-name unbox-parameter c-type unbox-parameter ;
-
-GENERIC: unbox-return ( c-type -- )
-
-M: c-type unbox-return f swap c-type-unbox ;
-
-M: c-type-name unbox-return c-type unbox-return ;
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 GENERIC: heap-size ( name -- size )
 
-M: c-type-name heap-size c-type heap-size ;
-
 M: abstract-c-type heap-size size>> ;
 
-GENERIC: stack-size ( name -- size )
-
-M: c-type-name stack-size c-type stack-size ;
-
-M: c-type stack-size size>> cell align ;
-
-GENERIC: byte-length ( seq -- n ) flushable
-
-M: byte-array byte-length length ; inline
-
-M: f byte-length drop 0 ; inline
-
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
 MIXIN: value-type
 
-: c-getter ( name -- quot )
+MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
-    c-type-getter [
+    [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
-        [ "Cannot read struct fields with this type" throw ]
-    ] unless* ;
 
-: c-type-getter-boxer ( name -- quot )
+MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
-    [ c-getter ] [ c-type-boxer-quot ] bi append ;
+    [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
+    [ c-type-setter ]
+    bi append ;
 
-: c-setter ( name -- quot )
+: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
-    c-type-setter [
+    [ swapd heap-size * >fixnum ] keep ; inline
-        [ "Cannot write struct fields with this type" throw ]
-    ] unless* ;
 
-: array-accessor ( c-type quot -- def )
+: alien-element ( n c-ptr c-type -- value )
-    [
+    array-accessor alien-value ; inline
-        \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
-    ] [ ] make ;
 
-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
+    [ name>> CHAR: * prefix "alien.c-types" create ]
-    (( c-ptr -- value )) define-inline ;
+    [ '[ 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:
+: >c-bool ( ? -- int ) 1 0 ? ; inline
-    ptrdiff_t intptr_t uintptr_t size_t
+
-    char* uchar* ;
+: 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
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            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
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            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 ;

basis/alien/data/data-docs.factor

@@ -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 }
+{ $subsections memory>byte-array } ;
-"You can copy a byte array to memory unsafely:"
-{ $subsections byte-array>memory } ;
 
 ARTICLE: "c-pointers" "Passing pointers to C functions"
 "The following Factor objects may be passed to C function parameters with pointer types:"
@@ -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: }
+{ $subsections "alien.enums" POSTPONE: ENUM: }
-"C types can be aliased for convenience and consitency with native library documentation:"
+"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." ;
 

basis/alien/data/data.factor

@@ -1,7 +1,8 @@
-! (c)2009 Slava Pestov, Joe Groff bsd license
+! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings arrays
+USING: accessors alien alien.c-types alien.arrays alien.strings
-byte-arrays cpu.architecture fry io io.encodings.binary
+arrays byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words ;
+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
+    [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
-    '[ @ 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

basis/alien/debugger/debugger.factor

@@ -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 ;

basis/alien/enums/enums-docs.factor

@@ -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"

basis/alien/enums/enums-tests.factor

@@ -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

basis/alien/enums/enums.factor

@@ -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? ;

basis/alien/fortran/fortran-tests.factor

@@ -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

basis/alien/fortran/fortran.factor

@@ -1,11 +1,12 @@
 ! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex alien.data alien.parser
+USING: accessors alien alien.c-types alien.complex alien.data
-grouping alien.strings alien.syntax arrays ascii assocs
+alien.parser grouping alien.strings alien.syntax arrays ascii
-byte-arrays combinators combinators.short-circuit fry generalizations
+assocs byte-arrays combinators combinators.short-circuit fry
-kernel lexer macros math math.parser namespaces parser sequences
+generalizations kernel lexer macros math math.parser namespaces
-splitting stack-checker vectors vocabs.parser words locals
+parser sequences sequences.generalizations splitting
-io.encodings.ascii io.encodings.string shuffle effects math.ranges
+stack-checker vectors vocabs.parser words locals
-math.order sorting strings system alien.libraries ;
+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
+    "I77" "libI77.so" cdecl add-library
-    "F77" "libF77.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: f2c-abi fortran-c-abi cdecl ;
-M: g95-abi fortran-c-abi "cdecl" ;
+M: g95-abi fortran-c-abi cdecl ;
-M: gfortran-abi fortran-c-abi "cdecl" ;
+M: gfortran-abi fortran-c-abi cdecl ;
-M: intel-unix-abi fortran-c-abi "cdecl" ;
+M: intel-unix-abi fortran-c-abi cdecl ;
-M: intel-windows-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 ;
 

basis/alien/libraries/libraries-docs.factor

@@ -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 macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
-    "    { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+    "    { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
     "    [ drop ]"
     "} cond >>"
 }

basis/alien/libraries/libraries.factor

@@ -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
 

basis/alien/parser/authors.txt

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

basis/alien/parser/parser-tests.factor

@@ -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
+    [ pointer: void ] [ "void*" parse-c-type ] unit-test
-    [ void* ] [ "int**" parse-c-type ] unit-test
+    [ pointer: int ] [ "int*" parse-c-type ] unit-test
-    [ void* ] [ "int***" parse-c-type ] unit-test
+    [ pointer: int* ] [ "int**" parse-c-type ] unit-test
-    [ void* ] [ "int****" parse-c-type ] unit-test
+    [ pointer: int** ] [ "int***" parse-c-type ] unit-test
-    [ char* ] [ "char*" parse-c-type ] unit-test
+    [ pointer: int*** ] [ "int****" parse-c-type ] unit-test
-    [ void* ] [ "char**" parse-c-type ] unit-test
+    [ c-string ] [ "c-string" parse-c-type ] unit-test
-    [ void* ] [ "char***" parse-c-type ] unit-test
-    [ void* ] [ "char****" parse-c-type ] unit-test
     [ char2 ] [ "char2" parse-c-type ] unit-test
-    [ char* ] [ "char2*" parse-c-type ] unit-test
+    [ 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

basis/alien/parser/parser.factor

@@ -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
+USING: accessors alien alien.c-types alien.libraries arrays
-alien.libraries arrays assocs classes combinators
+assocs classes combinators combinators.short-circuit
-combinators.short-circuit compiler.units effects grouping
+compiler.units effects grouping kernel parser sequences
-kernel parser sequences splitting words fry locals lexer
+splitting words fry locals lexer namespaces summary math
-namespaces summary math vocabs.parser ;
+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 "{" =
+    scan {
-    [ drop \ } parse-until >array ]
+        { [ dup "{" = ] [ drop \ } parse-until >array ] }
-    [ parse-c-type ] if ; 
+        { [ 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 )
+ERROR: *-in-c-type-name name ;
-    scan current-vocab create {
+
+: 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' )
+: CREATE-C-TYPE ( -- word )
-    [ length ]
+    scan (CREATE-C-TYPE) ;
-    [
-        [ CHAR: * = ] trim-head
-        [ length - CHAR: * <array> append ] keep
-    ] bi
-    [ parse-c-type ] dip ;
 
-: parse-arglist ( parameters return -- types effect )
+<PRIVATE
-    [
+GENERIC: return-type-name ( type -- name )
-        2 group [ first2 normalize-c-arg 2array ] map
+
-        unzip [ "," ?tail drop ] map
+M: object return-type-name drop "void" ;
-    ]
+M: word return-type-name name>> ;
-    [ [ { } ] [ name>> 1array ] if-void ]
+M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
-    bi* <effect> ;
+
+: 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 )
+: function-effect ( names return -- effect )
-    return function normalize-c-arg :> ( return function )
+    [ { } ] [ return-type-name 1array ] if-void <effect> ;
-    function create-in dup reset-generic
-    return library function
-    parameters return parse-arglist [ function-quot ] dip ;
 
-: parse-arg-tokens ( -- tokens )
+: create-function ( name -- word )
-    ";" parse-tokens [ "()" subseq? not ] filter ;
+    create-in dup reset-generic ;
 
-: (FUNCTION:) ( -- word quot effect )
+:: (make-function) ( return function library types names -- quot effect )
-    scan "c-library" get scan parse-arg-tokens make-function ;
+    return library function types function-quot
+    names return function-effect ;
 
-: define-function ( return library function parameters -- )
+:: make-function ( return function library types names -- word quot effect )
-    make-function define-declared ;
+    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 )
+:: make-callback-type ( lib return type-name types names -- word quot effect )
-    return type-name normalize-c-arg :> ( return type-name )
     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 names return function-effect "callback-effect" set-word-prop
-    type-word callback-effect "callback-effect" set-word-prop
     type-word lib "callback-library" set-word-prop
     type-word return types lib library-abi callback-quot (( quot -- alien )) ;
 
 : (CALLBACK:) ( -- word quot effect )
-    "c-library" get
+    current-library get
-    scan scan parse-arg-tokens make-callback-type ;
+    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 ;

basis/alien/prettyprint/prettyprint-tests.factor

@@ -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

basis/alien/prettyprint/prettyprint.factor

@@ -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
+USING: accessors kernel combinators alien alien.enums
-alien.parser alien.syntax arrays assocs effects math.parser
+alien.strings alien.c-types alien.parser alien.syntax arrays
-prettyprint.backend prettyprint.custom prettyprint.sections
+assocs effects math.parser prettyprint prettyprint.backend
-definitions see see.private sequences strings words ;
+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 -- )
+<PRIVATE
-M: word pprint-c-type pprint-word ;
+GENERIC: pointer-string ( pointer -- string/f )
-M: wrapper pprint-c-type wrapped>> pprint-word ;
+M: object pointer-string drop f ;
-M: string pprint-c-type text ;
+M: word pointer-string [ record-vocab ] [ name>> ] bi ;
-M: array pprint-c-type pprint* ;
+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* ;
 
-M: alien-function-word definer
+: pprint-function ( word quot -- )
-    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 ]
+    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 synopsis*
+    {
+        [ seeing-word ]
+        [ def>> second pprint-library ]
+        [ definer. ]
+        [ [ 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>> ;

basis/alien/remote-control/remote-control.factor

@@ -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

basis/alien/syntax/syntax-docs.factor

@@ -1,6 +1,6 @@
 IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.libraries
+USING: alien alien.c-types alien.enums alien.libraries classes.struct
-classes.struct help.markup help.syntax see ;
+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 ) ;"
+    "LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
-    "USE: compiler"
     "\"the question\" 42 the_answer"
     "The answer to the question is 42."
 } }
-{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
+"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:
+HELP: ENUM:
-{ $syntax "C-ENUM: words... ;" }
+{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
-{ $values { "words" "a sequence of word names" } }
+{ $values { "type" "a name to typedef to int or f" } { "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." }
+{ $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." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
 { $examples
     "Here is an example enumeration definition:"
-    { $code "C-ENUM: red green blue ;" }
+    { $code "ENUM: color_t red { green 3 } blue ;" }
-    "It is equivalent to the following series of definitions:"
+    "The following expression returns true:"
-    { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
+    { $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
+{ $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 to enable circular dependencies. For example:"
+{ $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" } }

basis/alien/syntax/syntax.factor

@@ -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
+USING: accessors arrays alien alien.c-types alien.enums alien.arrays
-alien.arrays alien.strings kernel math namespaces parser
+alien.strings kernel math namespaces parser sequences words
-sequences words quotations math.parser splitting grouping
+quotations math.parser splitting grouping effects assocs
-effects assocs combinators lexer strings.parser alien.parser 
+combinators lexer strings.parser alien.parser fry vocabs.parser
-fry vocabs.parser words.constant alien.libraries ;
+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:
+SYNTAX: ENUM:
-    ";" parse-tokens
+    parse-enum define-enum ;
-    [ [ create-in ] dip define-constant ] each-index ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;
 
-ERROR: no-such-symbol name library ;
-
-: address-of ( name library -- value )
-    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
-
 SYNTAX: &:
-    scan "c-library" get '[ _ _ address-of ] append! ;
+    scan current-library get '[ _ _ address-of ] append! ;
-
-: global-quot ( type word -- quot )
-    name>> "c-library" get '[ _ _ address-of 0 ]
-    swap c-type-getter-boxer append ;
-
-: define-global ( type word -- )
-    [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
 
 SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
+
+SYNTAX: pointer:
+    scan-c-type <pointer> suffix! ;

basis/base64/base64.factor

@@ -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* ;
 

basis/biassocs/biassocs.factor

@@ -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 ;

basis/binary-search/binary-search-tests.factor

@@ -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

basis/binary-search/binary-search.factor

@@ -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
+USING: accessors arrays combinators hints kernel locals math
-math.order combinators hints arrays ;
+math.order sequences sequences.private ;
 IN: binary-search
 
 <PRIVATE
 
-: midpoint ( seq -- elt )
+:: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
-    [ midpoint@ ] keep nth-unsafe ; inline
+    from to + 2/ :> midpoint@
+    midpoint@ seq nth-unsafe :> midpoint
 
-: decide ( quot seq -- quot seq <=> )
+    to from - 1 <= [
-    [ midpoint swap call ] 2keep rot ; inline
+        midpoint@ midpoint
-
-: finish ( quot slice -- i elt )
-    [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
-    [ drop ] [ dup ] [ ] tri* nth ; inline
-
-DEFER: (search)
-
-: keep-searching ( seq quot -- slice )
-    [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
-
-: (search) ( quot: ( elt -- <=> ) seq -- i elt )
-    dup length 1 <= [
-        finish
     ] [
-        decide {
+        midpoint quot call {
-            { +eq+ [ finish ] }
+            { +eq+ [ midpoint@ midpoint ] }
-            { +lt+ [ [ (head) ] keep-searching ] }
+            { +lt+ [ seq from midpoint@ quot (search) ] }
-            { +gt+ [ [ (tail) ] keep-searching ] }
+            { +gt+ [ seq midpoint@ to quot (search) ] }
         } case
     ] if ; inline recursive
 
 PRIVATE>
 
-: search ( seq quot -- i elt )
+: search ( seq quot: ( elt -- <=> ) -- i elt )
-    over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
+    over empty? [ 2drop f f ] [ [ 0 over length ] dip (search) ] if ;
     inline
 
 : natural-search ( obj seq -- i elt )

basis/bit-arrays/bit-arrays-tests.factor

@@ -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

basis/bit-arrays/bit-arrays.factor

@@ -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
+USING: alien alien.data accessors io.binary math math.bitwise
-kernel.private sequences sequences.private byte-arrays
+alien.accessors kernel kernel.private sequences
-parser prettyprint.custom fry ;
+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 )
+: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
-    over n>byte alien-unsigned-1 swap 7 bitand ; inline
 
-: set-bit ( ? byte bit -- byte )
+: bit-index ( n bit-array -- bit# byte# byte-array )
-    2^ rot [ bitor ] [ bitnot bitand ] if ; inline
+    [ >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*
+    bit-index [ toggle-bit ] change-nth-unsafe ; inline
-    [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ; 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 = [
+    dup 0 =
-        <bit-array>
+    [ <bit-array> ]
-    ] [
+    [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
-        [ log2 1 + <bit-array> 0 ] keep
-        [ dup 0 = ] [
-            [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            [ 1 + ] [ -8 shift ] bi*
-        ] until 2drop
-    ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length iota <reversed> [
+    underlying>> le> ;
-        alien-unsigned-1 swap 8 shift bitor
-    ] with each ;
 
 INSTANCE: bit-array sequence
 

basis/bit-sets/bit-sets-docs.factor

@@ -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." } ;

basis/bit-sets/bit-sets-tests.factor

@@ -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{ bit-set f ?{ t f t f t f } } ] [
-    ?{ t f f f t f }
+    T{ bit-set f ?{ t f f f t f } }
-    ?{ f f t f t f } bit-set-union
+    T{ bit-set f ?{ f f t f t f } } union
 ] unit-test
 
-[ ?{ f f f f t f } ] [
+[ T{ bit-set f ?{ f f f f t f } } ] [
-    ?{ t f f f t f }
+    T{ bit-set f ?{ t f f f t f } }
-    ?{ f f t f t f } bit-set-intersect
+    T{ bit-set f ?{ f f t f t f } } intersect
 ] unit-test
 
-[ ?{ t f t f f f } ] [
+[ f ] [ T{ bit-set f ?{ t f f f t f } } null? ] unit-test
-    ?{ t t t f f f }
+[ t ] [ T{ bit-set f ?{ f f f f f f } } null? ] unit-test
-    ?{ f t f f t t } bit-set-diff
+
+[ 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

basis/bit-sets/bit-sets.factor

@@ -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 ;

basis/bitstreams/bitstreams.factor

@@ -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 )

basis/bootstrap/compiler/compiler.factor

@@ -20,10 +20,8 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"prettyprint" vocab [
+{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when
-    "stack-checker.errors.prettyprint" require
+{ "boostrap.compiler" "debugger" } "alien.debugger" require-when
-    "alien.prettyprint" require
-] when
 
 "cpu." cpu name>> append require
 
@@ -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

basis/bootstrap/compiler/timing/tags.txt

@@ -1 +1 @@
-untested
+not loaded

basis/bootstrap/compiler/timing/timing.factor

@@ -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.finalization
-QUALIFIED: compiler.cfg.stacks.global
 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

basis/bootstrap/handbook/handbook.factor

@@ -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

basis/bootstrap/help/help.factor

@@ -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

basis/bootstrap/image/download/download.factor

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

basis/bootstrap/image/image.factor

@@ -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
+prettyprint sequences sequences.generalizations strings sbufs
-assocs system layouts splitting grouping growable classes
+vectors words quotations assocs system layouts splitting
-classes.private classes.builtin classes.tuple
+grouping growable classes classes.private classes.builtin
-classes.tuple.private vocabs vocabs.loader source-files
+classes.tuple classes.tuple.private vocabs vocabs.loader
-definitions debugger quotations.private combinators
+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 ] }
+        { "ppc" [ drop "-ppc" append ] }
-        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        { "x86.32" [ nip "-x86.32" append ] }
-        [ nip ]
+        { "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 -- )
+: jit-dlsym ( name rc -- )
-    rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+    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

basis/bootstrap/stage2.factor

@@ -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

basis/bootstrap/threads/threads.factor

@@ -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 [
+{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
-    "debugger.threads" require
-] when
 
 [ yield ] yield-hook set-global

basis/bootstrap/tools/tools.factor

@@ -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

basis/bootstrap/ui/tools/tools.factor

@@ -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" } "ui.backend.cocoa.tools" require-when
-        "ui.backend.cocoa.tools" require
-    ] when
 
     "ui.tools.walker" require
 ] when

basis/boxes/boxes.factor

@@ -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>>
+    check-box [ f ] change-value f >>occupied drop ; inline
-    [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
 
 : ?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

basis/cairo/ffi/ffi.factor

@@ -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 winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
-    { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "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
+ENUM: cairo_status_t
-C-ENUM:
     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
+ENUM: cairo_operator_t
-C-ENUM:
     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
+ENUM: cairo_antialias_t
-C-ENUM:
     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
+ENUM: cairo_fill_rule_t
-C-ENUM:
     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
+ENUM: cairo_line_cap_t
-C-ENUM:
     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
+ENUM: cairo_line_join_t
-C-ENUM:
     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
+ENUM: cairo_font_slant_t
-C-ENUM:
     CAIRO_FONT_SLANT_NORMAL
     CAIRO_FONT_SLANT_ITALIC
     CAIRO_FONT_SLANT_OBLIQUE ;
 
-TYPEDEF: int cairo_font_weight_t
+ENUM: cairo_font_weight_t
-C-ENUM:
     CAIRO_FONT_WEIGHT_NORMAL
     CAIRO_FONT_WEIGHT_BOLD ;
 
-TYPEDEF: int cairo_subpixel_order_t
+ENUM: cairo_subpixel_order_t
-C-ENUM:
     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
+ENUM: cairo_hint_style_t
-C-ENUM:
     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
+ENUM: cairo_hint_metrics_t
-C-ENUM:
     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
+ENUM: cairo_font_type_t
-C-ENUM:
     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
+ENUM: cairo_path_data_type_t
-C-ENUM:
     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
+ENUM: cairo_surface_type_t
-C-ENUM:
     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
+ENUM: cairo_format_t
-C-ENUM:
     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
+ENUM: cairo_pattern_type_t
-C-ENUM:
     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
+ENUM: cairo_extend_t
-C-ENUM:
     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
+ENUM: cairo_filter_t
-C-ENUM:
     CAIRO_FILTER_FAST
     CAIRO_FILTER_GOOD
     CAIRO_FILTER_BEST

basis/calendar/calendar-docs.factor

@@ -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

basis/calendar/calendar-tests.factor

@@ -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

basis/calendar/calendar.factor

@@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3
 : day-abbreviation3 ( n -- string )
     day-abbreviations3 nth ; inline
 
-: average-month ( -- ratio ) 30+5/12 ; inline
+CONSTANT: average-month 30+5/12
-: months-per-year ( -- integer ) 12 ; inline
+CONSTANT: months-per-year 12
-: days-per-year ( -- ratio ) 3652425/10000 ; inline
+CONSTANT: days-per-year 3652425/10000
-: hours-per-year ( -- ratio ) 876582/100 ; inline
+CONSTANT: hours-per-year 876582/100
-: minutes-per-year ( -- ratio ) 5259492/10 ; inline
+CONSTANT: minutes-per-year 5259492/10
-: seconds-per-year ( -- integer ) 31556952 ; inline
+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 ;

basis/calendar/format/format.factor

@@ -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
+USING: accessors arrays calendar calendar.format.macros
-sequences io accessors arrays io.streams.string splitting
+combinators io io.streams.string kernel math math.functions
-combinators calendar calendar.format.macros present ;
+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

basis/calendar/model/model.factor

@@ -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
+    time-thread
+] "calendar.model" add-startup-hook

basis/calendar/unix/unix.factor

@@ -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>> ;

basis/channels/channels.factor

@@ -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 )
-    [
+    [ self ] dip
     notify senders>>
     [ (from) ] unless-empty
-    ] curry "channel receive" suspend ;
+    "channel receive" suspend ;

basis/checksums/md5/md5.factor

@@ -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 )
+: uint-array-cast-le ( byte-array -- uint-array )
-    byte-array>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) ]

basis/checksums/openssl/openssl.factor

@@ -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>
+    { { int EVP_MAX_MD_SIZE } int }
-    [ EVP_DigestFinal_ex ssl-error ] 2keep
+    [ EVP_DigestFinal_ex ssl-error ]
-    *int memory>byte-array ;
+    [ memory>byte-array ]
+    with-out-parameters ;
 
 PRIVATE>
 

basis/checksums/sha/sha.factor

@@ -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 ;

basis/circular/circular.factor

@@ -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

basis/classes/struct/struct-docs.factor

@@ -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

basis/classes/struct/struct-tests.factor

@@ -1,12 +1,14 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data ascii
+USING: accessors alien alien.c-types alien.data alien.syntax ascii
-assocs byte-arrays classes.struct classes.tuple.private classes.tuple
+assocs byte-arrays classes.struct classes.tuple.parser
-combinators compiler.tree.debugger compiler.units destructors
+classes.tuple.private classes.tuple combinators compiler.tree.debugger
-io.encodings.utf8 io.pathnames io.streams.string kernel libc
+compiler.units destructors io.encodings.utf8 io.pathnames
-literals math mirrors namespaces prettyprint
+io.streams.string kernel libc literals math mirrors namespaces
-prettyprint.config see sequences specialized-arrays system
+prettyprint prettyprint.config see sequences specialized-arrays
-tools.test parser lexer eval layouts generic.single classes ;
+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 }

basis/classes/struct/struct.factor

@@ -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>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
-    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (reader-quot)
     [ [ offset>> ] [ bits>> ] bi bit-reader ]
@@ -112,18 +112,24 @@ M: struct-bit-slot-spec (reader-quot)
 GENERIC: (writer-quot) ( slot -- quot )
 
 M: struct-slot-spec (writer-quot)
-    [ type>> c-setter ]
+    [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
-    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (writer-quot)
-    [ offset>> ] [ bits>> ] bi bit-writer
+    [ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
-    [ >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
@@ -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 -- )
+: large-struct? ( type -- ? )
-    [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
+    {
-
+        { [ dup void? ] [ drop f ] }
-M: struct-c-type unbox-parameter
+        { [ dup base-type struct-c-type? not ] [ drop f ] }
-    [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
+        [ return-struct-in-registers? not ]
-
+    } cond ;
-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 ;
 
 <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 ;
@@ -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

basis/cocoa/application/application.factor

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

basis/cocoa/cocoa.factor

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

basis/cocoa/enumeration/enumeration.factor

@@ -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
 

basis/cocoa/messages/messages.factor

@@ -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
+USING: accessors alien alien.c-types alien.data alien.strings
-classes.struct continuations combinators compiler compiler.alien
+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
+macros memoize io.encodings.utf8 effects layouts libc lexer init
-libc.private lexer init core-foundation fry generalizations
+core-foundation fry generalizations specialized-arrays ;
-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
+    over class-exists? [ drop ] [ call( -- ) ] if
-    dup objc_getClass [
+    dup class-exists? [
         [ objc_getClass register-objc-methods ]
         [ objc_getMetaClass register-objc-methods ] bi
     ] [ drop ] if ;

basis/cocoa/nibs/nibs.factor

@@ -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
+USING: alien.c-types alien.data cocoa.application cocoa.messages
-cocoa.runtime kernel cocoa alien.c-types core-foundation
+cocoa.classes cocoa.runtime cocoa core-foundation
-core-foundation.arrays ;
+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
+    f
-    swap [ *void* CF>array ] [ drop f ] if ;
+    { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+    with-out-parameters
+    swap [ CF>array ] [ drop f ] if ;

basis/cocoa/plists/plists.factor

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

basis/cocoa/runtime/runtime.factor

@@ -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 ) ;
 

basis/cocoa/subclassing/subclassing.factor

@@ -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 )

basis/combinators/smart/smart-tests.factor

@@ -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

basis/combinators/smart/smart.factor

@@ -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
+USING: accessors fry generalizations sequences.generalizations
-stack-checker math sequences ;
+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 ] ;

basis/command-line/command-line-docs.factor

@@ -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:"

basis/compiler/alien/alien.factor

@@ -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 ;

basis/compiler/alien/summary.txt

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

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -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

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -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 )
+: aliases ( vreg -- vregs )
-
-M: integer aliases
     #! 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
+! Maps vreg -> slot# -> insn# of last store or f
-SYMBOL: insn#
+SYMBOL: recent-stores
 
-! Load/store history, for dead store elimination
+! A set of insn#s of dead stores
-TUPLE: load insn# ;
+SYMBOL: dead-stores
-TUPLE: store insn# ;
 
-: new-action ( class -- action )
+: dead-store ( insn# -- ) dead-stores get adjoin ;
-    insn# get swap boa ; inline
 
-! Maps vreg -> slot# -> sequence of loads/stores
+:: set-ac ( vreg ac -- )
-SYMBOL: histories
-
-: history ( vreg -- history ) histories get at ;
-
-: set-ac ( vreg ac -- )
     #! Set alias class of newly-seen vreg.
-    {
+    H{ } clone vreg recent-stores get set-at
-        [ drop H{ } clone swap histories get set-at ]
+    H{ } clone vreg live-slots get set-at
-        [ drop H{ } clone swap live-slots get set-at ]
+    ac vreg vregs>acs get set-at
-        [ swap vregs>acs get set-at ]
+    vreg ac acs>vregs get push-at ;
-        [ acs>vregs get push-at ]
-    } 2cleave ;
 
 : 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.
-    [
+    [ recent-stores get at delete-at ] with each-alias ;
-        history [ load new-action swap ?push ] change-at
-    ] with each-alias ;
 
 : record-computed-slot ( vreg -- )
     #! Computed load is like a load of every slot touched so far
-    [
+    [ recent-stores get at clear-assoc ] each-alias ;
-        history values [ load new-action swap push ] each
-    ] each-alias ;
 
-: remember-slot ( value slot#/f vreg -- )
+:: remember-slot ( value slot# vreg -- )
-    over
+    slot# [
-    [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+        slot# vreg record-constant-slot
-    [ 2nip record-computed-slot ] if ;
+        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 -- )
+:: record-constant-set-slot ( insn# slot# vreg -- )
-    history [
+    vreg recent-stores get at :> recent-stores
-        dup empty? [ dup last store? [ dup pop* ] when ] unless
+    slot# recent-stores at [ dead-store ] when*
-        store new-action swap ?push
+    insn# slot# recent-stores set-at ;
-    ] change-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 -- )
+:: remember-set-slot ( insn# slot# vreg -- )
-    over [
+    slot# [
-        [ record-constant-set-slot ]
+        insn# slot# vreg record-constant-set-slot
-        [ kill-constant-set-slot ] 2bi
+        slot# vreg kill-constant-set-slot
-    ] [ nip kill-computed-set-slot ] if ;
+    ] [ vreg 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 ;
 
 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' )
+GENERIC: analyze-aliases ( insn -- insn' )
-    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
 
-    0 ac-counter set
+M: insn analyze-aliases ;
-    next-ac heap-ac set
 
-    \ ##vm-field-ptr set-new-ac
+M: vreg-insn analyze-aliases
-    \ ##alien-global set-new-ac
-
-    dup local-live-in [ set-heap-ac ] each ;
-
-GENERIC: analyze-aliases* ( insn -- insn' )
-
-M: 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*
+M: ##allocation analyze-aliases
-    call-next-method
-    dup [ val>> ] [ dst>> ] bi constants get set-at ;
-
-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 [
+    2dup live-slot dup
-        2nip any-rep \ ##copy new-insn analyze-aliases* nip
+    [ 2nip <copy> analyze-aliases nip ]
-    ] [
+    [ drop remember-slot ]
-        drop remember-slot
+    if ;
-    ] 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*
+M:: ##write analyze-aliases ( insn -- insn )
-    dup
+    insn src>> resolve :> src
-    [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
+    insn insn-slot# :> slot#
-    [ remember-set-slot drop ] [ load-slot ] 3bi ;
+    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
+        dst>> f \ ##load-reference new-insn
-        analyze-aliases*
+        analyze-aliases
     ] when ;
 
-: analyze-aliases ( insns -- insns' )
+GENERIC: eliminate-dead-stores ( insn -- ? )
-    [ insn# set analyze-aliases* ] map-index sift ;
 
-SYMBOL: live-stores
+M: ##set-slot-imm eliminate-dead-stores
+    insn#>> dead-stores get in? not ;
 
-: compute-live-stores ( -- )
+M: insn eliminate-dead-stores drop t ;
-    histories get
-    values [
-        values [ [ store? ] filter [ insn#>> ] map ] map concat
-    ] map concat unique
-    live-stores set ;
 
-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' )
+: reset-alias-analysis ( -- )
-    dup insn-slot# [
+    recent-stores get clear-assoc
-        insn# get live-stores get key? [
+    vregs>acs get clear-assoc
-            drop f
+    acs>vregs get clear-assoc
-        ] unless
+    live-slots get clear-assoc
-    ] when ;
+    copies get clear-assoc
+    dead-stores get table>> clear-assoc
 
-M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
+    next-ac heap-ac set
-
+    \ ##vm-field set-new-ac
-M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
+    \ ##alien-global set-new-ac ;
-
-M: insn eliminate-dead-stores* ;
-
-: eliminate-dead-stores ( insns -- insns' )
-    [ insn# set eliminate-dead-stores* ] map-index sift ;
 
 : alias-analysis-step ( insns -- insns' )
-    init-alias-analysis
+    reset-alias-analysis
-    analyze-aliases
+    [ local-live-in [ set-heap-ac ] each ]
-    compute-live-stores
+    [ 0 [ [ insn#<< ] [ drop 1 + ] 2bi ] reduce drop ]
-    eliminate-dead-stores ;
+    [ [ analyze-aliases ] map! [ eliminate-dead-stores ] filter! ] tri ;
 
-: alias-analysis ( cfg -- cfg' )
+: alias-analysis ( cfg -- cfg )
-    [ alias-analysis-step ] local-optimization ;
+    init-alias-analysis
+    dup [ alias-analysis-step ] simple-optimization ;

basis/compiler/cfg/block-joining/block-joining.factor

@@ -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 ;

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -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
+USING: accessors combinators combinators.short-circuit kernel
-sequences assocs namespaces vectors fry arrays splitting
+math math.order sequences assocs namespaces vectors fry arrays
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
+splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
-compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
+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 ]
+            [ kill-block?>> >>kill-block? ]
             [ number>> >>number ]
-        tri ;
+        } cleave ;
 
 : new-blocks ( bb -- copies )
     dup predecessors>> [

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -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
+USING: namespaces accessors math math.order assocs kernel
-combinators make classes words cpu.architecture layouts
+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 -- )
+M:: ##local-allot compute-stack-frame* ( insn -- )
-    frame-required? on
+    frame-required
-    stack-frame [ max-stack-frame ] change ;
+    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
+M: ##stack-frame compute-stack-frame*
-    ##alien-invoke
+    frame-required
-    ##alien-indirect
+    stack-frame>> param-area-size [ max ] change ;
-    ##alien-assembly
-    ##alien-callback ;
 
-M: stack-frame-insn compute-stack-frame*
+: vm-frame-required ( -- )
-    stack-frame>> request-stack-frame ;
+    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*
+M: ##call compute-stack-frame* drop frame-required ;
-    frame-required? on
+M: ##alien-callback compute-stack-frame* drop frame-required ;
-    stack-frame new
+M: ##spill compute-stack-frame* drop frame-required ;
-        swap tagged-values>> length cells >>gc-root-size
+M: ##reload compute-stack-frame* drop frame-required ;
-        t >>calls-vm?
-    request-stack-frame ;
 
-M: _spill-area-size compute-stack-frame*
+M: ##float>integer compute-stack-frame*
-    n>> stack-frame get (>>spill-area-size) ;
+    drop integer-float-needs-stack-frame? [ frame-required ] when ;
 
-M: insn compute-stack-frame*
+M: ##integer>float compute-stack-frame*
-    class frame-required? word-prop [
+    drop integer-float-needs-stack-frame? [ frame-required ] when ;
-        frame-required? on
-    ] when ;
 
-\ _spill t frame-required? set-word-prop
+M: insn compute-stack-frame* drop ;
-\ ##unary-float-function t frame-required? set-word-prop
-\ ##binary-float-function t frame-required? set-word-prop
 
-: compute-stack-frame ( insns -- )
+: finalize-stack-frame ( stack-frame -- )
-    frame-required? off
+    dup [ params>> ] [ allot-area-align>> ] bi align >>allot-area-base
-    stack-frame new stack-frame set
+    dup [ [ allot-area-base>> ] [ allot-area-size>> ] bi + ] [ spill-area-align>> ] bi align >>spill-area-base
-    [ compute-stack-frame* ] each
+    dup stack-frame-size >>total-size drop ;
-    stack-frame get 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*
+: compute-stack-frame ( cfg -- stack-frame/f )
-    drop frame-required? get [ stack-frame get _prologue ] when ;
+    [ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ]
+    [ frame-required? get [ <stack-frame> ] [ drop f ] if ]
+    bi ;
 
-M: ##epilogue insert-pro/epilogues*
+: build-stack-frame ( cfg -- cfg )
-    drop frame-required? get [ stack-frame get _epilogue ] when ;
+    0 param-area-size set
-
+    0 allot-area-size set
-M: insn insert-pro/epilogues* , ;
+    cell allot-area-align set
-
+    dup compute-stack-frame >>stack-frame ;
-: 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 ;

basis/compiler/cfg/builder/alien/alien.factor

@@ -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 ;

basis/compiler/cfg/builder/alien/boxing/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/builder/alien/boxing/boxing.factor

@@ -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 ;

basis/compiler/cfg/builder/alien/params/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/builder/alien/params/params.factor

@@ -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

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -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 ]

basis/compiler/cfg/builder/builder-tests.factor

@@ -1,17 +1,19 @@
 USING: tools.test kernel sequences words sequences.private fry
-prettyprint alien alien.accessors math.private compiler.tree.builder
+prettyprint alien alien.accessors math.private
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
+compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
+compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg arrays locals byte-arrays kernel.private math
+compiler.cfg.optimizer compiler.cfg.rpo
-slots.private vectors sbufs strings math.partial-dispatch
+compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
-hashtables assocs combinators.short-circuit
+arrays locals byte-arrays kernel.private math slots.private
-strings.private accessors compiler.cfg.instructions ;
+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 -- )
+: unit-test-builder ( quot -- )
-    '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+    '[ _ 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-indirect ]
-    [ int { int } "cdecl" [ ] alien-callback ]
+    [ 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 } word '[ _ declare 10 _ execute ] unit-test-builder
-        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { 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 } word '[ _ declare 10 _ execute ] unit-test-builder
-        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
     ] each
     
-    { float class } \ set-alien-float '[ _ declare 10 _ 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-cfg
+    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
     
-    { float class } \ set-alien-double '[ _ declare 10 _ 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-cfg
+    { 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 } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
-    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
 ] each
 
 : count-insns ( quot insn-check -- ? )
-    [ test-mr [ instructions>> ] map ] dip
+    [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
-    '[ _ count ] map-sum ; inline
+    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

basis/compiler/cfg/builder/builder.factor

@@ -19,8 +19,7 @@ compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.builder.blocks
 compiler.cfg.stacks
-compiler.cfg.stacks.local
+compiler.cfg.stacks.local ;
-compiler.alien ;
 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 ;
 

basis/compiler/cfg/cfg.factor

@@ -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 ;

basis/compiler/cfg/checker/checker.factor

@@ -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 ]
+    [ check-successors ] each-basic-block ;
-    [ build-mr check-mr ]
-    bi ;

basis/compiler/cfg/comparisons/comparisons.factor

@@ -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' )

basis/compiler/cfg/copy-prop/copy-prop-tests.factor

@@ -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

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -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
+USING: sets kernel namespaces assocs accessors sequences grouping
-combinators compiler.cfg.rpo compiler.cfg.renaming
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.predecessors ;
+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 phis get key? [ redundant-phi ] [
-        { [ dup all-equal? ] [ useless-phi ] }
+        dup sift
-        { [ dup phis get key? ] [ redundant-phi ] }
+        dup all-equal?
-        [ record-phi ]
+        [ nip useless-phi ]
-    } cond ;
+        [ drop record-phi ] if
+    ] if ;
+
+M: vreg-insn visit-insn
+    defs-vreg [ dup record-copy ] when* ;
 
 M: insn visit-insn drop ;
 
-: collect-copies ( cfg -- )
+: (collect-copies) ( cfg -- )
-    H{ } clone copies set
     [
-        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 ] [
+    copies get renamings set
-        renamings set
+    [ [ update-insn ] filter! ] simple-optimization ;
-        [
-            instructions>> [ update-insn ] filter! drop
-        ] each-basic-block
-    ] if ;
 
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
     needs-predecessors
 
-    [ collect-copies ]
+    dup collect-copies
-    [ rename-copies ]
+    dup rename-copies ;
-    [ ]
-    tri ;

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -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 )
+:: compute-in-set ( bb out-sets dfa -- set )
-
-M: kill-block compute-in-set 3drop f ;
-
-M:: basic-block compute-in-set ( bb out-sets dfa -- set )
     ! Only consider initialized sets.
+    bb kill-block?>> [ f ] [
         bb dfa predecessors
         [ out-sets key? ] filter
         [ out-sets at ] map
-    bb dfa join-sets ;
+        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 )
+:: compute-out-set ( bb in-sets dfa -- set )
-
+    bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
-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 ;
 
 :: update-out-set ( bb in-sets out-sets dfa -- ? )
     bb in-sets dfa compute-out-set

basis/compiler/cfg/dce/dce-tests.factor

@@ -11,41 +11,41 @@ IN: compiler.cfg.dce.tests
     entry>> instructions>> ; 
 
 [ V{
-    T{ ##load-immediate { dst 1 } { val 8 } }
+    T{ ##load-integer { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    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-integer { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    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-integer { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    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