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

.gitignore

@@ -20,3 +20,4 @@ temp
 logs
 work
 build-support/wordsize
+*.bak

Makefile

@@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 
 clean:
 	rm -f vm/*.o
-	rm -f factor*.dll libfactor*.*
+	rm -f factor*.dll libfactor.{a,so,dylib}
 
 vm/resources.o:
 	$(WINDRES) vm/factor.rs vm/resources.o

basis/concurrency/combinators/combinators-docs.factor

@@ -27,11 +27,17 @@ HELP: parallel-filter
 { $errors "Throws an error if one of the iterations throws an error." } ;
 
 ARTICLE: "concurrency.combinators" "Concurrent combinators"
-"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
+"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
+$nl
+"Concurrent sequence combinators:"
 { $subsection parallel-each }
 { $subsection 2parallel-each }
 { $subsection parallel-map }
 { $subsection 2parallel-map }
-{ $subsection parallel-filter } ;
+{ $subsection parallel-filter }
+"Concurrent cleave combinators:"
+{ $subsection parallel-cleave }
+{ $subsection parallel-spread }
+{ $subsection parallel-napply } ;
 
 ABOUT: "concurrency.combinators"

basis/concurrency/combinators/combinators-tests.factor

@@ -1,6 +1,7 @@
 IN: concurrency.combinators.tests
 USING: concurrency.combinators tools.test random kernel math 
-concurrency.mailboxes threads sequences accessors arrays ;
+concurrency.mailboxes threads sequences accessors arrays
+math.parser ;
 
 [ [ drop ] parallel-each ] must-infer
 { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
@@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ;
 ] unit-test
 
 [ { f } [ "OOPS" throw ] parallel-each ] must-fail
+
+[ "1a" "4b" "3c" ] [
+    2
+    { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave
+    [ number>string ] 3 parallel-napply
+    { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
+] unit-test

basis/concurrency/combinators/combinators.factor

@@ -1,34 +1,58 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.futures concurrency.count-downs sequences
-kernel ;
+kernel macros fry combinators generalizations ;
 IN: concurrency.combinators
 
 <PRIVATE
+
 : (parallel-each) ( n quot -- )
-    >r <count-down> r> keep await ; inline
+    [ <count-down> ] dip keep await ; inline
+
 PRIVATE>
 
 : parallel-each ( seq quot -- )
     over length [
-        [ >r curry r> spawn-stage ] 2curry each
+        '[ _ curry _ spawn-stage ] each
     ] (parallel-each) ; inline
 
 : 2parallel-each ( seq1 seq2 quot -- )
     2over min-length [
-        [ >r 2curry r> spawn-stage ] 2curry 2each
+        '[ _ 2curry _ spawn-stage ] 2each
     ] (parallel-each) ; inline
 
 : parallel-filter ( seq quot -- newseq )
-    over >r pusher >r each r> r> like ; inline
+    over [ pusher [ each ] dip ] dip like ; inline
 
 <PRIVATE
+
+: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
+
 : future-values dup [ ?future ] change-each ; inline
+
 PRIVATE>
 
 : parallel-map ( seq quot -- newseq )
-    [ curry future ] curry map future-values ;
+    [future] map future-values ; inline
-    inline
 
 : 2parallel-map ( seq1 seq2 quot -- newseq )
-    [ 2curry future ] curry 2map future-values ;
+    '[ _ 2curry future ] 2map future-values ;
+
+<PRIVATE
+
+: (parallel-spread) ( n -- spread-array )
+    [ ?future ] <repetition> ; inline
+
+: (parallel-cleave) ( quots -- quot-array spread-array )
+    [ [future] ] map dup length (parallel-spread) ; inline
+
+PRIVATE>
+
+MACRO: parallel-cleave ( quots -- )
+    (parallel-cleave) '[ _ cleave _ spread ] ;
+
+MACRO: parallel-spread ( quots -- )
+    (parallel-cleave) '[ _ spread _ spread ] ;
+
+MACRO: parallel-napply ( quot n -- )
+    [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;

basis/io/unix/files/files.factor

@@ -117,8 +117,8 @@ M: unix stat>file-info ( stat -- file-info )
         [ stat-st_blksize >>blocksize ]
     } cleave ;
 
-M: unix stat>type ( stat -- type )
+: n>file-type ( n -- type )
-    stat-st_mode S_IFMT bitand {
+    S_IFMT bitand {
         { S_IFREG [ +regular-file+ ] }
         { S_IFDIR [ +directory+ ] }
         { S_IFCHR [ +character-device+ ] }
@@ -129,6 +129,9 @@ M: unix stat>type ( stat -- type )
         [ drop +unknown+ ]
     } case ;
 
+M: unix stat>type ( stat -- type )
+    stat-st_mode n>file-type ;
+
 ! Linux has no extra fields in its stat struct
 os {
     { macosx  [ "io.unix.files.bsd" require ] }
@@ -150,7 +153,7 @@ os {
 
 M: unix >directory-entry ( byte-array -- directory-entry )
     [ dirent-d_name utf8 alien>string ]
-    [ dirent-d_type ] bi directory-entry boa ;
+    [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
 
 M: unix (directory-entries) ( path -- seq )
     [

basis/io/windows/files/files.factor

@@ -114,11 +114,6 @@ M: windows delete-directory ( path -- )
     normalize-path
     RemoveDirectory win32-error=0/f ;
 
-M: windows >directory-entry ( byte-array -- directory-entry )
-    [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
-    [ WIN32_FIND_DATA-dwFileAttributes ]
-    bi directory-entry boa ;
-
 : find-first-file ( path -- WIN32_FIND_DATA handle )
     "WIN32_FIND_DATA" <c-object> tuck
     FindFirstFile
@@ -177,6 +172,14 @@ TUPLE: windows-file-info < file-info attributes ;
 : win32-file-type ( n -- symbol )
     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 
+TUPLE: windows-directory-entry < directory-entry attributes ;
+
+M: windows >directory-entry ( byte-array -- directory-entry )
+    [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
+    [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+    [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
+    tri windows-directory-entry boa ;
+
 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
     [ \ windows-file-info new ] dip
     {

basis/locals/locals-tests.factor

@@ -388,6 +388,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
 
+[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]

basis/prettyprint/prettyprint.factor

@@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
 definitions effects classes.builtin classes.tuple io.files
 classes continuations hashtables classes.mixin classes.union
 classes.intersection classes.predicate classes.singleton
-combinators quotations sets accessors colors ;
+combinators quotations sets accessors colors parser ;
 IN: prettyprint
 
 : make-pprint ( obj quot -- block in use )
@@ -48,6 +48,22 @@ IN: prettyprint
     dupd remove [ { "syntax" "scratchpad" } member? not ] filter
     use. in. ;
 
+: vocab-names ( words -- vocabs )
+    dictionary get
+    [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
+
+: prelude. ( -- )
+    in get use get vocab-names vocabs. ;
+
+[
+    nl
+    "Restarts were invoked adding vocabularies to the search path." print
+    "To avoid doing this in the future, add the following USING:" print
+    "and IN: forms at the top of the source file:" print nl
+    prelude.
+    nl
+] print-use-hook set-global
+
 : with-use ( obj quot -- )
     make-pprint vocabs. do-pprint ; inline
 

basis/regexp/backend/backend.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math state-tables vars vectors ;
+USING: accessors hashtables kernel math state-tables vectors ;
 IN: regexp.backend
 
 TUPLE: regexp

basis/regexp/classes/classes.factor

@@ -30,6 +30,10 @@ M: ascii-class class-member? ( obj class -- ? )
 M: digit-class class-member? ( obj class -- ? )
     drop digit? ;
 
+M: c-identifier-class class-member? ( obj class -- ? )
+    drop
+    { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
+
 M: alpha-class class-member? ( obj class -- ? )
     drop alpha? ;
 

basis/regexp/parser/parser.factor

@@ -294,6 +294,7 @@ ERROR: unrecognized-escape char ;
     read1
     {
         { CHAR: \ [ CHAR: \ <constant> ] }
+        { CHAR: / [ CHAR: / <constant> ] }
         { CHAR: ^ [ CHAR: ^ <constant> ] }
         { CHAR: $ [ CHAR: $ <constant> ] }
         { CHAR: - [ CHAR: - <constant> ] }

basis/regexp/regexp-tests.factor

@@ -46,6 +46,18 @@ IN: regexp-tests
 [ t ] [ "a" ".+" <regexp> matches? ] unit-test
 [ t ] [ "ab" ".+" <regexp> matches? ] unit-test
 
+[ t ] [ " " "[\\s]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\s]" <regexp> matches? ] unit-test
+[ f ] [ " " "[\\S]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[\\S]" <regexp> matches? ] unit-test
+[ f ] [ " " "[\\w]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[\\w]" <regexp> matches? ] unit-test
+[ t ] [ " " "[\\W]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\W]" <regexp> matches? ] unit-test
+
+[ t ] [ "/" "\\/" <regexp> matches? ] unit-test
+
+[ t ] [ "a" R' a'i matches? ] unit-test
 
 [ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
 [ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
@@ -334,3 +346,7 @@ IN: regexp-tests
 [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
 
 [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
+
+[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+
+[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test

basis/regexp/regexp.factor

@@ -28,7 +28,7 @@ IN: regexp
 : match ( string regexp -- pair )
     <dfa-traverser> do-match return-match ;
 
-: match* ( string regexp -- pair )
+: match* ( string regexp -- pair captured-groups )
     <dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
 
 : matches? ( string regexp -- ? )
@@ -129,8 +129,6 @@ IN: regexp
 : option? ( option regexp -- ? )
     options>> key? ;
 
-USE: multiline
-/*
 M: regexp pprint*
     [
         [
@@ -139,4 +137,3 @@ M: regexp pprint*
             case-insensitive swap option? [ "i" % ] when
         ] "" make
     ] keep present-text ;
-*/

basis/tools/completion/completion.factor

@@ -72,7 +72,9 @@ IN: tools.completion
     ] if ;
 
 : string-completions ( short strs -- seq )
-    [ dup ] { } map>assoc completions ;
+    dup zip completions ;
 
 : limited-completions ( short candidates -- seq )
-    completions dup length 1000 > [ drop f ] when ;
+    [ completions ] [ drop ] 2bi
+    2dup [ length 50 > ] [ empty? ] bi* and
+    [ 2drop f ] [ drop 50 short head ] if ;

basis/ui/gadgets/buttons/buttons.factor

@@ -6,7 +6,6 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
 ui.render math.geometry.rect locals alien.c-types ;
-
 IN: ui.gadgets.buttons
 
 TUPLE: button < border pressed? selected? quot ;
@@ -111,10 +110,10 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
 
 : checkmark-points ( dim -- points )
     {
-        [ { 0 0 } v* ]
+        [ { 0 0 } v* { 0.5 0.5 } v+ ]
-        [ { 1 1 } v* ]
+        [ { 1 1 } v* { 0.5 0.5 } v+ ]
-        [ { 0 1 } v* ]
+        [ { 1 0 } v* { -0.3 0.5 } v+ ]
-        [ { 1 0 } v* ]
+        [ { 0 1 } v* { -0.3 0.5 } v+ ]
     } cleave 4array ;
 
 : checkmark-vertices ( dim -- vertices )

basis/ui/gadgets/grid-lines/grid-lines.factor

@@ -18,18 +18,16 @@ SYMBOL: grid-dim
     grid-dim get spin set-axis ;
 
 : draw-grid-lines ( gaps orientation -- )
-    grid get rot grid-positions grid get rect-dim suffix [
+    [ grid get swap grid-positions grid get rect-dim suffix ] dip
-        grid-line-from/to gl-line
+    [ [ v- ] curry map ] keep
-    ] with each ;
+    [ swap grid-line-from/to gl-line ] curry each ;
 
 M: grid-lines draw-boundary
     color>> gl-color [
         dup grid set
         dup rect-dim half-gap v- grid-dim set
         compute-grid
-        [ { -0.5 -0.5 } gl-translate { 1 0 } draw-grid-lines ]
+        [ { 1 0 } draw-grid-lines ]
-        [
+        [ { 0 1 } draw-grid-lines ]
-            { 0.5 -0.5 } gl-translate
+        bi*
-            { 0 1 } draw-grid-lines
-        ] bi*
     ] with-scope ;

basis/unix/bsd/bsd.factor

@@ -83,16 +83,6 @@ C-STRUCT: passwd
 : SEEK_CUR 1 ; inline
 : SEEK_END 2 ; inline
 
-: DT_UNKNOWN   0 ; inline
-: DT_FIFO      1 ; inline
-: DT_CHR       2 ; inline
-: DT_DIR       4 ; inline
-: DT_BLK       6 ; inline
-: DT_REG       8 ; inline
-: DT_LNK      10 ; inline
-: DT_SOCK     12 ; inline
-: DT_WHT      14 ; inline
-
 os {
     { macosx  [ "unix.bsd.macosx"  require ] }
     { freebsd [ "unix.bsd.freebsd" require ] }

basis/unix/unix.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc
 sequences continuations byte-arrays strings math namespaces
 system combinators vocabs.loader qualified accessors
 stack-checker macros locals generalizations unix.types
-debugger io prettyprint ;
+debugger io prettyprint io.files ;
 IN: unix
 
 : PROT_NONE   0 ; inline
@@ -20,6 +20,29 @@ IN: unix
 
 : NGROUPS_MAX 16 ; inline
 
+: DT_UNKNOWN   0 ; inline
+: DT_FIFO      1 ; inline
+: DT_CHR       2 ; inline
+: DT_DIR       4 ; inline
+: DT_BLK       6 ; inline
+: DT_REG       8 ; inline
+: DT_LNK      10 ; inline
+: DT_SOCK     12 ; inline
+: DT_WHT      14 ; inline
+
+: dirent-type>file-type ( ch -- type )
+    {
+        { DT_BLK  [ +block-device+ ] }
+        { DT_CHR  [ +character-device+ ] }
+        { DT_DIR  [ +directory+ ] }
+        { DT_LNK  [ +symbolic-link+ ] }
+        { DT_SOCK [ +socket+ ] }
+        { DT_FIFO [ +fifo+ ] }
+        { DT_REG  [ +regular-file+ ] }
+        { DT_WHT  [ +whiteout+ ] }
+        [ drop +unknown+ ]
+    } case ;
+
 C-STRUCT: group
     { "char*" "gr_name" }
     { "char*" "gr_passwd" }

basis/validators/validators-tests.factor

@@ -52,3 +52,5 @@ namespaces assocs ;
 [ "4561_2612_1234_5467" v-credit-card ] must-fail
 
 [ "4561-2621-1234-5467" v-credit-card ] must-fail
+
+[ t ] [ "http://double.co.nz/w?v=foo" dup v-url = ] unit-test

basis/validators/validators.factor

@@ -62,9 +62,7 @@ IN: validators
     v-regexp ;
 
 : v-url ( str -- str )
-    "URL"
+    "URL" R' (ftp|http|https)://\S+' v-regexp ;
-    R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
-    v-regexp ;
 
 : v-captcha ( str -- str )
     dup empty? [ "must remain blank" throw ] unless ;

build-support/factor.sh

@@ -131,10 +131,10 @@ check_library_exists() {
         $ECHO "***Factor will compile NO_UI=1"
         NO_UI=1
     fi
-    rm -f $GCC_TEST
+    $DELETE -f $GCC_TEST
-    check_ret rm
+    check_ret $DELETE
-    rm -f $GCC_OUT
+    $DELETE -f $GCC_OUT
-    check_ret rm
+    check_ret $DELETE
     $ECHO "found."
 }
 
@@ -209,7 +209,7 @@ c_find_word_size() {
     gcc -o $C_WORD $C_WORD.c
     WORD=$(./$C_WORD)
     check_ret $C_WORD
-    rm -f $C_WORD*
+    $DELETE -f $C_WORD*
 }
 
 intel_macosx_word_size() {
@@ -236,17 +236,30 @@ find_word_size() {
 
 set_factor_binary() {
     case $OS in
-        # winnt) FACTOR_BINARY=factor-nt;;
+        winnt) FACTOR_BINARY=factor.exe;;
-        # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
         *) FACTOR_BINARY=factor;;
     esac
 }
 
+set_factor_library() {
+    case $OS in
+        winnt) FACTOR_LIBRARY=factor.dll;;
+        macosx) FACTOR_LIBRARY=libfactor.dylib;;
+        *) FACTOR_LIBRARY=libfactor.a;;
+    esac
+}
+
+set_factor_image() {
+    FACTOR_IMAGE=factor.image
+}
+
 echo_build_info() {
     $ECHO OS=$OS
     $ECHO ARCH=$ARCH
     $ECHO WORD=$WORD
     $ECHO FACTOR_BINARY=$FACTOR_BINARY
+    $ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY
+    $ECHO FACTOR_IMAGE=$FACTOR_IMAGE
     $ECHO MAKE_TARGET=$MAKE_TARGET
     $ECHO BOOT_IMAGE=$BOOT_IMAGE
     $ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
@@ -255,6 +268,8 @@ echo_build_info() {
     $ECHO DOWNLOADER=$DOWNLOADER
     $ECHO CC=$CC
     $ECHO MAKE=$MAKE
+    $ECHO COPY=$COPY
+    $ECHO DELETE=$DELETE
 }
 
 check_os_arch_word() {
@@ -312,6 +327,8 @@ find_build_info() {
     find_architecture
     find_word_size
     set_factor_binary
+    set_factor_library
+    set_factor_image
     set_build_info
     set_downloader
     set_gcc
@@ -339,6 +356,28 @@ cd_factor() {
     check_ret cd
 }
 
+set_copy() {
+    case $OS in
+        winnt) COPY=cp;;
+        *) COPY=cp;;
+    esac
+}
+
+set_delete() {
+    case $OS in
+        winnt) DELETE=rm;;
+        *) DELETE=rm;;
+    esac
+}
+
+backup_factor() {
+    $ECHO "Backing up factor..."
+    $COPY $FACTOR_BINARY $FACTOR_BINARY.bak
+    $COPY $FACTOR_LIBRARY $FACTOR_LIBRARY.bak
+    $COPY $FACTOR_IMAGE $FACTOR_IMAGE.bak
+    $ECHO "Done with backup."
+}
+
 check_makefile_exists() {
     if [[ ! -e "Makefile" ]] ; then
         echo ""
@@ -366,9 +405,9 @@ make_factor() {
 
 update_boot_images() {
     echo "Deleting old images..."
-    rm checksums.txt* > /dev/null 2>&1
+    $DELETE checksums.txt* > /dev/null 2>&1
-    rm $BOOT_IMAGE.* > /dev/null 2>&1
+    $DELETE $BOOT_IMAGE.* > /dev/null 2>&1
-    rm temp/staging.*.image > /dev/null 2>&1
+    $DELETE temp/staging.*.image > /dev/null 2>&1
     if [[ -f $BOOT_IMAGE ]] ; then
         get_url http://factorcode.org/images/latest/checksums.txt
         factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
@@ -382,7 +421,7 @@ update_boot_images() {
         if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
             echo "Your disk boot image matches the one on factorcode.org."
         else
-            rm $BOOT_IMAGE > /dev/null 2>&1
+            $DELETE $BOOT_IMAGE > /dev/null 2>&1
             get_boot_image;
         fi
     else
@@ -459,6 +498,7 @@ install() {
 update() {
     get_config_info
     git_pull_factorcode
+    backup_factor
     make_clean
     make_factor
 }
@@ -469,12 +509,12 @@ update_bootstrap() {
 }
 
 refresh_image() {
-    ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
+    ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit"
     check_ret factor
 }
 
 make_boot_image() {
-    ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
+    ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit"
     check_ret factor
 
 }
@@ -513,6 +553,9 @@ if [[ -n "$2" ]] ; then
     parse_build_info $2
 fi
 
+set_copy
+set_delete
+
 case "$1" in
     install) install ;;
     install-x11) install_build_system_apt; install ;;

core/io/files/files.factor

@@ -175,6 +175,7 @@ SYMBOL: +character-device+
 SYMBOL: +block-device+
 SYMBOL: +fifo+
 SYMBOL: +socket+
+SYMBOL: +whiteout+
 SYMBOL: +unknown+
 
 ! File metadata

core/kernel/kernel-docs.factor

@@ -606,7 +606,7 @@ HELP: 3compose
 } ;
 
 HELP: dip
-{ $values { "obj" object } { "quot" quotation } }
+{ $values { "x" object } { "quot" quotation } }
 { $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
 { $notes "The following are equivalent:"
     { $code ">r foo bar r>" }
@@ -614,7 +614,7 @@ HELP: dip
 } ;
 
 HELP: 2dip
-{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
+{ $values { "x" object } { "y" object } { "quot" quotation } }
 { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
 { $notes "The following are equivalent:"
     { $code ">r >r foo bar r> r>" }
@@ -622,7 +622,7 @@ HELP: 2dip
 } ;
 
 HELP: 3dip
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
 { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
 { $notes "The following are equivalent:"
     { $code ">r >r >r foo bar r> r> r>" }

core/kernel/kernel.factor

@@ -55,18 +55,18 @@ DEFER: if
 
 : 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
 
-: dip ( obj quot -- obj ) swap slip ; inline
+: dip ( x quot -- x ) swap slip ; inline
 
-: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
+: 2dip ( x y quot -- x y ) swap >r dip r> ; inline
 
-: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline
+: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline
 
 ! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) dupd dip ; inline
 
-: 2keep ( x y quot -- x y ) 2over 2slip ; inline
+: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline
 
-: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
+: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline
 
 ! Cleavers
 : bi ( x p q -- )

core/parser/parser.factor

@@ -52,7 +52,12 @@ SYMBOL: in
 
 M: parsing-word stack-effect drop (( parsed -- parsed )) ;
 
-ERROR: no-current-vocab ;
+TUPLE: no-current-vocab ;
+
+: no-current-vocab ( -- vocab )
+    \ no-current-vocab boa
+    { { "Define words in scratchpad vocabulary" "scratchpad" } }
+    throw-restarts dup set-in ;
 
 : current-vocab ( -- str )
     in get [ no-current-vocab ] unless* ;
@@ -64,20 +69,33 @@ ERROR: no-current-vocab ;
 
 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
 
-: word-restarts ( possibilities -- restarts )
+: word-restarts ( name possibilities -- restarts )
-    natural-sort [
+    natural-sort
-        [
+    [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
-            "Use the " swap vocabulary>> " vocabulary" 3append
+    swap "Defer word in current vocabulary" swap 2array
-        ] keep
+    suffix ;
-    ] { } map>assoc ;
 
 ERROR: no-word-error name ;
 
+: <no-word-error> ( name possibilities -- error restarts )
+    [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
+
+SYMBOL: amended-use?
+
+SYMBOL: do-what-i-mean?
+
+: no-word-restarted ( restart-value -- word )
+    dup word?
+    [ amended-use? on dup vocabulary>> (use+) ]
+    [ create-in ]
+    if ;
+
 : no-word ( name -- newword )
-    dup \ no-word-error boa
+    dup words-named [ forward-reference? not ] filter
-    swap words-named [ forward-reference? not ] filter
+    dup length 1 = do-what-i-mean? get and
-    word-restarts throw-restarts
+    [ nip first no-word-restarted ]
-    dup vocabulary>> (use+) ;
+    [ <no-word-error> throw-restarts no-word-restarted ]
+    if ;
 
 : check-forward ( str word -- word/f )
     dup forward-reference? [
@@ -127,7 +145,9 @@ ERROR: staging-violation word ;
 : parsed ( accum obj -- accum ) over push ;
 
 : (parse-lines) ( lexer -- quot )
-    [ f parse-until >quotation ] with-lexer ;
+    [
+        f parse-until >quotation
+    ] with-lexer ;
 
 : parse-lines ( lines -- quot )
     lexer-factory get call (parse-lines) ;
@@ -206,8 +226,18 @@ SYMBOL: interactive-vocabs
         call
     ] with-scope ; inline
 
+SYMBOL: print-use-hook
+
+print-use-hook global [ [ ] or ] change-at
+
 : parse-fresh ( lines -- quot )
-    [ parse-lines ] with-file-vocabs ;
+    [
+        amended-use? off
+        parse-lines
+        amended-use? get [
+            print-use-hook get call
+        ] when
+    ] with-file-vocabs ;
 
 : parsing-file ( file -- )
     "quiet" get [

extra/cairo/gadgets/gadgets.factor

@@ -1,58 +1,34 @@
 ! Copyright (C) 2008 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math opengl.gadgets kernel
+USING: sequences math kernel byte-arrays cairo.ffi cairo
-byte-arrays cairo.ffi cairo io.backend
+io.backend ui.gadgets accessors opengl.gl arrays fry
-ui.gadgets accessors opengl.gl
+classes ui.render namespaces ;
-arrays fry classes ;
 
 IN: cairo.gadgets
 
 : width>stride ( width -- stride ) 4 * ;
     
-: copy-cairo ( dim quot -- byte-array )
+GENERIC: render-cairo* ( gadget -- )
-    >r first2 over width>stride
-    [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
-    [ cairo_image_surface_create_for_data ] 3bi
-    r> with-cairo-from-surface ; inline
 
-TUPLE: cairo-gadget < texture-gadget ;
+: render-cairo ( gadget -- byte-array )
+    dup dim>> first2 over width>stride
+    [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ] 
+    [ cairo_image_surface_create_for_data ] 3bi
+    rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
+
+TUPLE: cairo-gadget < gadget ;
 
 : <cairo-gadget> ( dim -- gadget )
     cairo-gadget new-gadget
         swap >>dim ;
 
-M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
+M: cairo-gadget draw-gadget*
-
+    [ dim>> ] [ render-cairo ] bi
-: render-cairo ( dim quot -- bytes format )
+    origin get first2 glRasterPos2i
-    >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+    1.0 -1.0 glPixelZoom
-
+    >r first2 GL_BGRA GL_UNSIGNED_BYTE r>
-GENERIC: render-cairo* ( gadget -- )
+    glDrawPixels ;
-
-M: cairo-gadget render*
-    [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
-    render-cairo render-bytes* ;
-
-! maybe also texture>png
-! : cairo>png ( gadget path -- )
-!    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-!    [ height>> ] tri over width>stride
-!    cairo_image_surface_create_for_data
-!    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
 
 : copy-surface ( surface -- )
     cr swap 0 0 cairo_set_source_surface
     cr cairo_paint ;
-
-TUPLE: png-gadget < texture-gadget path ;
-: <png> ( path -- gadget )
-    png-gadget new-gadget
-        swap >>path ;
-
-M: png-gadget render*
-    path>> normalize-path cairo_image_surface_create_from_png
-    [ cairo_image_surface_get_width ]
-    [ cairo_image_surface_get_height 2array dup 2^-bounds ]
-    [ [ copy-surface ] curry copy-cairo ] tri
-    GL_BGRA render-bytes* ;
-
-M: png-gadget cache-key* path>> ;

extra/cap/cap.factor

@@ -6,7 +6,7 @@ models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )
-    dim>> product 3 * <byte-array> ;
+    dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
 
 : gl-screenshot ( gadget -- byte-array )
     [

extra/opengl/gadgets/gadgets.factor

@@ -47,6 +47,11 @@ C: <entry> cache-entry
     cache-key* textures get delete-at*
     [ tex>> delete-texture ] [ drop ] if ;
 
+: clear-textures ( -- )
+    textures get values [ tex>> delete-texture ] each
+    H{ } clone textures set-global
+    H{ } clone refcounts set-global ;
+
 M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
 
 M: texture-gadget ungraft* ( gadget -- )

extra/spheres/spheres.factor

@@ -15,16 +15,26 @@ main()
 ;
 
 STRING: plane-fragment-shader
+uniform float checker_size_inv;
+uniform vec4 checker_color_1, checker_color_2;
 varying vec3 object_position;
+
+bool
+checker_color(vec3 p)
+{
+    vec3 pprime = checker_size_inv * object_position;
+    return fract((floor(pprime.x) + floor(pprime.z)) * 0.5) == 0.0;
+}
+
 void
 main()
 {
     float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
     distance_factor = pow(distance_factor, 500.0)*0.5;
     
-    gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
+    gl_FragColor = checker_color(object_position)
-        ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
+        ? mix(checker_color_1, checker_color_2, distance_factor)
-        : vec4(1.0, distance_factor, distance_factor, 1.0);
+        : mix(checker_color_2, checker_color_1, distance_factor);
 }
 ;
 
@@ -213,7 +223,11 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
         ] with-gl-program
     ] [
         plane-program>> [
-            drop
+            {
+                [ "checker_size_inv" glGetUniformLocation 0.125 glUniform1f ]
+                [ "checker_color_1"  glGetUniformLocation 1.0 0.5 0.0 1.0 glUniform4f ]
+                [ "checker_color_2"  glGetUniformLocation 0.0 0.0 0.0 1.0 glUniform4f ]
+            } cleave
             GL_QUADS [
                 -1000.0 -30.0  1000.0 glVertex3f
                 -1000.0 -30.0 -1000.0 glVertex3f

extra/ui/render/test/test.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors colors arrays kernel sequences math byte-arrays
-namespaces cap graphics.bitmap
+namespaces grouping fry cap graphics.bitmap
 ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
 ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
 ui.render ui opengl opengl.gl ;
@@ -17,29 +17,45 @@ M: line-test draw-interior
         line-test >>interior
         { 1 10 } >>dim ;
 
-TUPLE: ui-render-test < pack { first-time? initial: t } ;
-
 : message-window ( text -- )
     <label> "Message" open-window ;
 
-: check-rendering ( gadget -- )
+SYMBOL: render-output
-    gl-screenshot
-    "resource:extra/ui/render/test/reference.bmp" load-bitmap array>>
-    = "perfect" "needs work" ? "Your UI rendering is " prepend
-    message-window ;
 
-M: ui-render-test draw-gadget*
+: twiddle ( bytes -- bytes )
-    [ call-next-method ] [
+    #! On Windows, white is { 253 253 253 } ?
-        dup first-time?>> [
+    [ 10 /i ] map ;
-            dup check-rendering
+
-            f >>first-time?
+: stride ( bitmap -- n ) width>> 3 * ;
-        ] when
+
-        drop
+: bitmap= ( bitmap1 bitmap2 -- ? )
+    [
+        [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi
+        '[ _ head twiddle ] map
+    ] bi@ = ;
+
+: check-rendering ( gadget -- )
+    screenshot
+    [ render-output set-global ]
+    [
+        "resource:extra/ui/render/test/reference.bmp" load-bitmap
+        bitmap= "is perfect" "needs work" ?
+        "Your UI rendering " prepend
+        message-window
     ] bi ;
 
+TUPLE: take-screenshot { first-time? initial: t } ;
+
+M: take-screenshot draw-boundary
+    dup first-time?>> [
+        over check-rendering
+        f >>first-time?
+    ] when
+    2drop ;
+
 : <ui-render-test> ( -- gadget )
-    \ ui-render-test new-gadget
+    <shelf>
-        { 1 0 } >>orientation
+        take-screenshot new >>boundary
         <gadget>
             black <solid> >>interior
             { 98 98 } >>dim

misc/factor.el

@@ -113,6 +113,14 @@ value from the existing code in the buffer."
   "Face for type (tuple) names."
   :group 'factor-faces)
 
+(defface factor-font-lock-constructor (factor--face font-lock-type-face)
+  "Face for constructors (<foo>)."
+  :group 'factor-faces)
+
+(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face)
+  "Face for setter words (>>foo)."
+  :group 'factor-faces)
+
 (defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
   "Face for parsing words."
   :group 'factor-faces)
@@ -146,6 +154,12 @@ value from the existing code in the buffer."
 (defconst factor--regex-type-definition
   (factor--regex-second-word '("TUPLE:")))
 
+(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
+
+(defconst factor--regex-constructor "<[^ >]+>")
+
+(defconst factor--regex-setter "\\W>>[^ ]+\\b")
+
 (defconst factor--regex-symbol-definition
   (factor--regex-second-word '("SYMBOL:")))
 
@@ -166,6 +180,9 @@ value from the existing code in the buffer."
     (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
     (,factor--regex-word-definition 2 'factor-font-lock-word-definition)
     (,factor--regex-type-definition 2 'factor-font-lock-type-definition)
+    (,factor--regex-parent-type 1 'factor-font-lock-type-definition)
+    (,factor--regex-constructor . 'factor-font-lock-constructor)
+    (,factor--regex-setter . 'factor-font-lock-setter-word)
     (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
     (,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
     (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
@@ -217,6 +234,144 @@ value from the existing code in the buffer."
     (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
     (modify-syntax-entry ?\" "\"    " factor-mode-syntax-table)))
 
+
+;;; Factor mode indentation:
+
+(make-variable-buffer-local
+ (defvar factor-indent-width factor-default-indent-width
+   "Indentation width in factor buffers. A local variable."))
+
+(defconst factor--regexp-word-start
+  (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+    (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
+
+(defun factor--guess-indent-width ()
+  "Chooses an indentation value from existing code."
+  (let ((word-cont "^ +[^ ]")
+        (iw))
+    (save-excursion
+      (beginning-of-buffer)
+      (while (not iw)
+        (if (not (re-search-forward factor--regexp-word-start nil t))
+            (setq iw factor-default-indent-width)
+          (forward-line)
+          (when (looking-at word-cont)
+            (setq iw (current-indentation))))))
+    iw))
+
+(defsubst factor--ppss-brackets-depth ()
+  (nth 0 (syntax-ppss)))
+
+(defsubst factor--ppss-brackets-start ()
+  (nth 1 (syntax-ppss)))
+
+(defsubst factor--indentation-at (pos)
+  (save-excursion (goto-char pos) (current-indentation)))
+
+(defconst factor--regex-closing-paren "[])}]")
+(defsubst factor--at-closing-paren-p ()
+  (looking-at factor--regex-closing-paren))
+
+(defsubst factor--at-first-char-p ()
+  (= (- (point) (line-beginning-position)) (current-indentation)))
+
+(defconst factor--regex-single-liner
+  (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
+                              "PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
+
+(defsubst factor--at-begin-of-def ()
+  (looking-at "\\([^ ]\\|^\\)+:"))
+
+(defsubst factor--looking-at-emptiness ()
+  (looking-at "^[ \t]*$"))
+
+(defun factor--at-end-of-def ()
+  (or (looking-at ".*;[ \t]*$")
+      (looking-at factor--regex-single-liner)))
+
+(defun factor--at-setter-line ()
+  (save-excursion
+    (beginning-of-line)
+    (if (not (factor--looking-at-emptiness))
+        (re-search-forward factor--regex-setter (line-end-position) t)
+      (forward-line -1)
+      (or (factor--at-constructor-line)
+          (factor--at-setter-line)))))
+
+(defun factor--at-constructor-line ()
+  (save-excursion
+    (beginning-of-line)
+    (re-search-forward factor--regex-constructor (line-end-position) t)))
+
+(defsubst factor--increased-indentation (&optional i)
+  (+ (or i (current-indentation)) factor-indent-width))
+(defsubst factor--decreased-indentation (&optional i)
+  (- (or i (current-indentation)) factor-indent-width))
+
+(defun factor--indent-in-brackets ()
+  (save-excursion
+    (beginning-of-line)
+    (when (or (and (re-search-forward factor--regex-closing-paren
+                                      (line-end-position) t)
+                   (not (backward-char)))
+              (> (factor--ppss-brackets-depth) 0))
+      (let ((op (factor--ppss-brackets-start)))
+        (when (> (line-number-at-pos) (line-number-at-pos op))
+          (if (factor--at-closing-paren-p)
+              (factor--indentation-at op)
+            (factor--increased-indentation (factor--indentation-at op))))))))
+
+(defun factor--indent-definition ()
+  (save-excursion
+    (beginning-of-line)
+    (when (factor--at-begin-of-def) 0)))
+
+(defun factor--indent-setter-line ()
+  (when (factor--at-setter-line)
+    (save-excursion
+      (let ((indent (and (factor--at-constructor-line) (current-indentation))))
+        (while (not (or indent
+                        (bobp)
+                        (factor--at-begin-of-def)
+                        (factor--at-end-of-def)))
+          (if (factor--at-constructor-line)
+              (setq indent (factor--increased-indentation))
+            (forward-line -1)))
+        indent))))
+
+(defun factor--indent-continuation ()
+  (save-excursion
+    (forward-line -1)
+    (while (and (not (bobp)) (factor--looking-at-emptiness))
+      (forward-line -1))
+    (if (or (factor--at-end-of-def) (factor--at-setter-line))
+        (factor--decreased-indentation)
+      (if (factor--at-begin-of-def)
+          (factor--increased-indentation)
+        (current-indentation)))))
+
+(defun factor--calculate-indentation ()
+  "Calculate Factor indentation for line at point."
+  (or (and (bobp) 0)
+      (factor--indent-definition)
+      (factor--indent-in-brackets)
+      (factor--indent-setter-line)
+      (factor--indent-continuation)
+      0))
+
+(defun factor--indent-line ()
+  "Indent current line as Factor code"
+  (let ((target (factor--calculate-indentation))
+        (pos (- (point-max) (point))))
+    (if (= target (current-indentation))
+        (if (< (current-column) (current-indentation))
+            (back-to-indentation))
+      (beginning-of-line)
+      (delete-horizontal-space)
+      (indent-to target)
+      (if (> (- (point-max) pos) (point))
+          (goto-char (- (point-max) pos))))))
+
 
 ;;; Factor mode commands:
 
@@ -314,105 +469,6 @@ value from the existing code in the buffer."
 (define-key factor-mode-map [return]   'newline-and-indent)
 (define-key factor-mode-map [tab]      'indent-for-tab-command)
 
-
-;;; Factor mode indentation:
-
-(make-variable-buffer-local
- (defvar factor-indent-width factor-default-indent-width
-   "Indentation width in factor buffers. A local variable."))
-
-(defconst factor--regexp-word-start
-  (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
-    (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
-
-(defun factor--guess-indent-width ()
-  "Chooses an indentation value from existing code."
-  (let ((word-cont "^ +[^ ]")
-        (iw))
-    (save-excursion
-      (beginning-of-buffer)
-      (while (not iw)
-        (if (not (re-search-forward factor--regexp-word-start nil t))
-            (setq iw factor-default-indent-width)
-          (forward-line)
-          (when (looking-at word-cont)
-            (setq iw (current-indentation))))))
-    iw))
-
-(defsubst factor--ppss-brackets-depth ()
-  (nth 0 (syntax-ppss)))
-
-(defsubst factor--ppss-brackets-start ()
-  (nth 1 (syntax-ppss)))
-
-(defsubst factor--line-indent (pos)
-  (save-excursion (goto-char pos) (current-indentation)))
-
-(defconst factor--regex-closing-paren "[])}]")
-(defsubst factor--at-closing-paren-p ()
-  (looking-at factor--regex-closing-paren))
-
-(defsubst factor--at-first-char-p ()
-  (= (- (point) (line-beginning-position)) (current-indentation)))
-
-(defconst factor--regex-single-liner
-  (format "^%s" (regexp-opt '("USE:" "IN:" "PRIVATE>" "<PRIVATE"))))
-
-(defun factor--at-end-of-def ()
-  (or (looking-at ".*;[ \t]*$")
-      (looking-at factor--regex-single-liner)))
-
-(defun factor--indent-in-brackets ()
-  (save-excursion
-    (beginning-of-line)
-    (when (or (and (re-search-forward factor--regex-closing-paren
-                                      (line-end-position) t)
-                   (not (backward-char)))
-               (> (factor--ppss-brackets-depth) 0))
-      (let ((op (factor--ppss-brackets-start)))
-        (when (> (line-number-at-pos) (line-number-at-pos op))
-          (if (factor--at-closing-paren-p)
-              (factor--line-indent op)
-            (+ (factor--line-indent op) factor-indent-width)))))))
-
-(defun factor--indent-definition ()
-  (save-excursion
-    (beginning-of-line)
-    (when (looking-at "\\([^ ]\\|^\\)+:") 0)))
-
-(defun factor--indent-continuation ()
-  (save-excursion
-    (forward-line -1)
-    (beginning-of-line)
-    (if (bobp) 0
-      (if (looking-at "^[ \t]*$")
-          (factor--indent-continuation)
-        (if (factor--at-end-of-def)
-            (- (current-indentation) factor-indent-width)
-          (if (factor--indent-definition)
-              (+ (current-indentation) factor-indent-width)
-            (current-indentation)))))))
-
-(defun factor--calculate-indentation ()
-  "Calculate Factor indentation for line at point."
-  (or (and (bobp) 0)
-      (factor--indent-definition)
-      (factor--indent-in-brackets)
-      (factor--indent-continuation)
-      0))
-
-(defun factor-indent-line ()
-  "Indent current line as Factor code"
-  (let ((target (factor--calculate-indentation))
-        (pos (- (point-max) (point))))
-    (if (= target (current-indentation))
-        (if (< (current-column) (current-indentation))
-            (back-to-indentation))
-      (beginning-of-line)
-      (delete-horizontal-space)
-      (indent-to target)
-      (if (> (- (point-max) pos) (point))
-          (goto-char (- (point-max) pos))))))
 
 
 ;; Factor mode:
@@ -426,12 +482,11 @@ value from the existing code in the buffer."
   (use-local-map factor-mode-map)
   (setq major-mode 'factor-mode)
   (setq mode-name "Factor")
-  (set (make-local-variable 'indent-line-function) #'factor-indent-line)
   (set (make-local-variable 'comment-start) "! ")
   (set (make-local-variable 'font-lock-defaults)
        '(factor-font-lock-keywords t nil nil nil))
   (set-syntax-table factor-mode-syntax-table)
-  (set (make-local-variable 'indent-line-function) 'factor-indent-line)
+  (set (make-local-variable 'indent-line-function) 'factor--indent-line)
   (setq factor-indent-width (factor--guess-indent-width))
   (setq indent-tabs-mode nil)
   (run-hooks 'factor-mode-hook))

vm/Config.x86.64

@@ -1 +1,2 @@
 PLAF_DLL_OBJS += vm/cpu-x86.64.o
+CFLAGS += -DFACTOR_64

vm/code_gc.c

@@ -333,12 +333,14 @@ void dump_heap(F_HEAP *heap)
 			break;
 		}
 
-		fprintf(stderr,"%lx %lx %s\n",(CELL)scan,scan->size,status);
+		print_cell_hex((CELL)scan); print_string(" ");
+		print_cell_hex(scan->size); print_string(" ");
+		print_string(status); print_string("\n");
 
 		scan = next_block(heap,scan);
 	}
 	
-	printf("%ld bytes of relocation data\n",size);
+	print_cell(size); print_string(" bytes of relocation data\n");
 }
 
 /* Compute where each block is going to go, after compaction */
@@ -460,9 +462,6 @@ void compact_code_heap(void)
 	/* Free all unreachable code blocks */
 	gc();
 
-	fprintf(stderr,"*** Code heap compaction...\n");
-	fflush(stderr);
-
 	/* Figure out where the code heap blocks are going to end up */
 	CELL size = compute_heap_forwarding(&code_heap);
 

vm/code_heap.c

@@ -238,10 +238,10 @@ CELL allot_code_block(CELL size)
 			CELL used, total_free, max_free;
 			heap_usage(&code_heap,&used,&total_free,&max_free);
 
-			fprintf(stderr,"Code heap stats:\n");
+			print_string("Code heap stats:\n");
-			fprintf(stderr,"Used: %ld\n",used);
+			print_string("Used: "); print_cell(used); nl();
-			fprintf(stderr,"Total free space: %ld\n",total_free);
+			print_string("Total free space: "); print_cell(total_free); nl();
-			fprintf(stderr,"Largest free block: %ld\n",max_free);
+			print_string("Largest free block: "); print_cell(max_free); nl();
 			fatal_error("Out of memory in add-compiled-block",0);
 		}
 	}

vm/data_gc.c

@@ -1,20 +1,5 @@
 #include "master.h"
 
-#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
-#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
-#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
-#define END_GC "end_gc: gc_elapsed=%ld\n"
-#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
-#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
-
-/* #define GC_DEBUG */
-
-#ifdef GC_DEBUG
-	#define GC_PRINT printf
-#else
-	INLINE void GC_PRINT() { }
-#endif
-
 CELL init_zone(F_ZONE *z, CELL size, CELL start)
 {
 	z->size = size;
@@ -36,8 +21,6 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	CELL aging_size,
 	CELL tenured_size)
 {
-	GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
-
 	young_size = align(young_size,DECK_SIZE);
 	aging_size = align(aging_size,DECK_SIZE);
 	tenured_size = align(tenured_size,DECK_SIZE);
@@ -438,8 +421,6 @@ void collect_gen_cards(CELL gen)
 old->new references */
 void collect_cards(void)
 {
-	GC_PRINT("Collect cards\n");
-
 	int i;
 	for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 		collect_gen_cards(i);
@@ -468,9 +449,7 @@ void collect_callstack(F_CONTEXT *stacks)
 		CELL top = (CELL)stacks->callstack_top;
 		CELL bottom = (CELL)stacks->callstack_bottom;
 
-		GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
 		iterate_callstack(top,bottom,collect_stack_frame);
-		GC_PRINT("Done\n");
 	}
 }
 
@@ -486,7 +465,6 @@ void collect_gc_locals(void)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
-	GC_PRINT("Collect roots\n");
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
@@ -759,14 +737,6 @@ void begin_gc(CELL requested_bytes)
 		so we set the newspace so the next generation. */
 		newspace = &data_heap->generations[collecting_gen + 1];
 	}
-
-#ifdef GC_DEBUG
-	printf("\n");
-	dump_generations();
-	printf("Newspace: ");
-	dump_zone(newspace);
-	printf("\n");
-#endif
 }
 
 void end_gc(CELL gc_elapsed)
@@ -823,8 +793,6 @@ void garbage_collection(CELL gen,
 		return;
 	}
 
-	GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
-
 	s64 start = current_millis();
 
 	performing_gc = true;
@@ -858,7 +826,6 @@ void garbage_collection(CELL gen,
 		}
 	}
 
-	GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
 	begin_gc(requested_bytes);
 
 	/* initialize chase pointer */
@@ -895,7 +862,6 @@ void garbage_collection(CELL gen,
 
 	CELL gc_elapsed = (current_millis() - start);
 
-	GC_PRINT(END_GC,gc_elapsed);
 	end_gc(gc_elapsed);
 
 	performing_gc = false;

vm/debug.c

@@ -15,20 +15,20 @@ void print_word(F_WORD* word, CELL nesting)
 	if(type_of(word->vocabulary) == STRING_TYPE)
 	{
 		print_chars(untag_string(word->vocabulary));
-		printf(":");
+		print_string(":");
 	}
 	
 	if(type_of(word->name) == STRING_TYPE)
 		print_chars(untag_string(word->name));
 	else
 	{
-		printf("#<not a string: ");
+		print_string("#<not a string: ");
 		print_nested_obj(word->name,nesting);
-		printf(">");
+		print_string(">");
 	}
 }
 
-void print_string(F_STRING* str)
+void print_factor_string(F_STRING* str)
 {
 	putchar('"');
 	print_chars(str);
@@ -51,12 +51,12 @@ void print_array(F_ARRAY* array, CELL nesting)
 
 	for(i = 0; i < length; i++)
 	{
-		printf(" ");
+		print_string(" ");
 		print_nested_obj(array_nth(array,i),nesting);
 	}
 
 	if(trimmed)
-		printf("...");
+		print_string("...");
 }
 
 void print_tuple(F_TUPLE* tuple, CELL nesting)
@@ -64,7 +64,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
 	F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
 	CELL length = to_fixnum(layout->size);
 
-	printf(" ");
+	print_string(" ");
 	print_nested_obj(layout->class,nesting);
 
 	CELL i;
@@ -80,19 +80,19 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
 
 	for(i = 0; i < length; i++)
 	{
-		printf(" ");
+		print_string(" ");
 		print_nested_obj(tuple_nth(tuple,i),nesting);
 	}
 
 	if(trimmed)
-		printf("...");
+		print_string("...");
 }
 
 void print_nested_obj(CELL obj, F_FIXNUM nesting)
 {
 	if(nesting <= 0 && !full_output)
 	{
-		printf(" ... ");
+		print_string(" ... ");
 		return;
 	}
 
@@ -101,35 +101,35 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
 	switch(type_of(obj))
 	{
 	case FIXNUM_TYPE:
-		printf("%ld",untag_fixnum_fast(obj));
+		print_fixnum(untag_fixnum_fast(obj));
 		break;
 	case WORD_TYPE:
 		print_word(untag_word(obj),nesting - 1);
 		break;
 	case STRING_TYPE:
-		print_string(untag_string(obj));
+		print_factor_string(untag_string(obj));
 		break;
 	case F_TYPE:
-		printf("f");
+		print_string("f");
 		break;
 	case TUPLE_TYPE:
-		printf("T{");
+		print_string("T{");
 		print_tuple(untag_object(obj),nesting - 1);
-		printf(" }");
+		print_string(" }");
 		break;
 	case ARRAY_TYPE:
-		printf("{");
+		print_string("{");
 		print_array(untag_object(obj),nesting - 1);
-		printf(" }");
+		print_string(" }");
 		break;
 	case QUOTATION_TYPE:
-		printf("[");
+		print_string("[");
 		quot = untag_object(obj);
 		print_array(untag_object(quot->array),nesting - 1);
-		printf(" ]");
+		print_string(" ]");
 		break;
 	default:
-		printf("#<type %ld @ %lx>",type_of(obj),obj);
+		print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj);
 		break;
 	}
 }
@@ -144,35 +144,35 @@ void print_objects(CELL start, CELL end)
 	for(; start <= end; start += CELLS)
 	{
 		print_obj(get(start));
-		printf("\n");
+		nl();
 	}
 }
 
 void print_datastack(void)
 {
-	printf("==== DATA STACK:\n");
+	print_string("==== DATA STACK:\n");
 	print_objects(ds_bot,ds);
 }
 
 void print_retainstack(void)
 {
-	printf("==== RETAIN STACK:\n");
+	print_string("==== RETAIN STACK:\n");
 	print_objects(rs_bot,rs);
 }
 
 void print_stack_frame(F_STACK_FRAME *frame)
 {
 	print_obj(frame_executing(frame));
-	printf("\n");
+	print_string("\n");
 	print_obj(frame_scan(frame));
-	printf("\n");
+	print_string("\n");
-	printf("%lx\n",(CELL)frame_executing(frame));
+	print_cell_hex((CELL)frame_executing(frame));
-	printf("%lx\n",(CELL)frame->xt);
+	print_cell_hex((CELL)frame->xt);
 }
 
 void print_callstack(void)
 {
-	printf("==== CALL STACK:\n");
+	print_string("==== CALL STACK:\n");
 	CELL bottom = (CELL)stack_chain->callstack_bottom;
 	CELL top = (CELL)stack_chain->callstack_top;
 	iterate_callstack(top,bottom,print_stack_frame);
@@ -180,11 +180,11 @@ void print_callstack(void)
 
 void dump_cell(CELL cell)
 {
-	printf("%08lx: ",cell);
+	print_cell_hex_pad(cell); print_string(": ");
 
 	cell = get(cell);
 
-	printf("%08lx tag %ld",cell,TAG(cell));
+	print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell));
 
 	switch(TAG(cell))
 	{
@@ -192,24 +192,29 @@ void dump_cell(CELL cell)
 	case BIGNUM_TYPE:
 	case FLOAT_TYPE:
 		if(cell == F)
-			printf(" -- F");
+			print_string(" -- F");
 		else if(cell < TYPE_COUNT<<TAG_BITS)
-			printf(" -- possible header: %ld",cell>>TAG_BITS);
+		{
+			print_string(" -- possible header: ");
+			print_cell(cell>>TAG_BITS);
+		}
 		else if(cell >= data_heap->segment->start
 			&& cell < data_heap->segment->end)
 		{
 			CELL header = get(UNTAG(cell));
 			CELL type = header>>TAG_BITS;
-			printf(" -- object; ");
+			print_string(" -- object; ");
 			if(TAG(header) == 0 && type < TYPE_COUNT)
-				printf(" type %ld",type);
+			{
+				print_string(" type "); print_cell(type);
+			}
 			else
-				printf(" header corrupt");
+				print_string(" header corrupt");
 		}
 		break;
 	}
 	
-	printf("\n");
+	nl();
 }
 
 void dump_memory(CELL from, CELL to)
@@ -222,32 +227,35 @@ void dump_memory(CELL from, CELL to)
 
 void dump_zone(F_ZONE *z)
 {
-	printf("start=%ld, size=%ld, here=%ld\n",
+	print_string("Start="); print_cell(z->start);
-		z->start,z->size,z->here - z->start);
+	print_string(", size="); print_cell(z->size);
+	print_string(", here="); print_cell(z->here - z->start); nl();
 }
 
 void dump_generations(void)
 {
-	int i;
+	CELL i;
 
-	printf("Nursery: ");
+	print_string("Nursery: ");
 	dump_zone(&nursery);
 	
 	for(i = 1; i < data_heap->gen_count; i++)
 	{
-		printf("Generation %d: ",i);
+		print_string("Generation "); print_cell(i); print_string(": ");
 		dump_zone(&data_heap->generations[i]);
 	}
 
 	for(i = 0; i < data_heap->gen_count; i++)
 	{
-		printf("Semispace %d: ",i);
+		print_string("Semispace "); print_cell(i); print_string(": ");
 		dump_zone(&data_heap->semispaces[i]);
 	}
 
-	printf("Cards: base=%lx, size=%lx\n",
+	print_string("Cards: base=");
-		(CELL)data_heap->cards,
+	print_cell((CELL)data_heap->cards);
-		(CELL)(data_heap->cards_end - data_heap->cards));
+	print_string(", size=");
+	print_cell((CELL)(data_heap->cards_end - data_heap->cards));
+	nl();
 }
 
 void dump_objects(F_FIXNUM type)
@@ -260,9 +268,10 @@ void dump_objects(F_FIXNUM type)
 	{
 		if(type == -1 || type_of(obj) == type)
 		{
-			printf("%lx ",obj);
+			print_cell_hex_pad(obj);
+			print_string(" ");
 			print_nested_obj(obj,2);
-			printf("\n");
+			nl();
 		}
 	}
 
@@ -277,9 +286,10 @@ void find_data_references_step(CELL *scan)
 {
 	if(look_for == *scan)
 	{
-		printf("%lx ",obj);
+		print_cell_hex_pad(obj);
+		print_string(" ");
 		print_nested_obj(obj,2);
-		printf("\n");
+		nl();
 	}
 }
 
@@ -312,9 +322,10 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL liter
 
 		if(look_for == get(scan))
 		{
-			printf("%lx ",obj);
+			print_cell_hex_pad(obj);
+			print_string(" ");
 			print_nested_obj(obj,2);
-			printf("\n");
+			nl();
 		}
 	}
 }
@@ -329,34 +340,34 @@ void factorbug(void)
 {
 	if(fep_disabled)
 	{
-		printf("Low level debugger disabled\n");
+		print_string("Low level debugger disabled\n");
 		exit(1);
 	}
 
-	open_console();
+	/* open_console(); */
 
-	printf("Starting low level debugger...\n");
+	print_string("Starting low level debugger...\n");
-	printf("  Basic commands:\n");
+	print_string("  Basic commands:\n");
-	printf("q                -- continue executing Factor - NOT SAFE\n");
+	print_string("q                -- continue executing Factor - NOT SAFE\n");
-	printf("im               -- save image to fep.image\n");
+	print_string("im               -- save image to fep.image\n");
-	printf("x                -- exit Factor\n");
+	print_string("x                -- exit Factor\n");
-	printf("  Advanced commands:\n");
+	print_string("  Advanced commands:\n");
-	printf("d <addr> <count> -- dump memory\n");
+	print_string("d <addr> <count> -- dump memory\n");
-	printf("u <addr>         -- dump object at tagged <addr>\n");
+	print_string("u <addr>         -- dump object at tagged <addr>\n");
-	printf(". <addr>         -- print object at tagged <addr>\n");
+	print_string(". <addr>         -- print object at tagged <addr>\n");
-	printf("t                -- toggle output trimming\n");
+	print_string("t                -- toggle output trimming\n");
-	printf("s r              -- dump data, retain stacks\n");
+	print_string("s r              -- dump data, retain stacks\n");
-	printf(".s .r .c         -- print data, retain, call stacks\n");
+	print_string(".s .r .c         -- print data, retain, call stacks\n");
-	printf("e                -- dump environment\n");
+	print_string("e                -- dump environment\n");
-	printf("g                -- dump generations\n");
+	print_string("g                -- dump generations\n");
-	printf("card <addr>      -- print card containing address\n");
+	print_string("card <addr>      -- print card containing address\n");
-	printf("addr <card>      -- print address containing card\n");
+	print_string("addr <card>      -- print address containing card\n");
-	printf("data             -- data heap dump\n");
+	print_string("data             -- data heap dump\n");
-	printf("words            -- words dump\n");
+	print_string("words            -- words dump\n");
-	printf("tuples           -- tuples dump\n");
+	print_string("tuples           -- tuples dump\n");
-	printf("refs <addr>      -- find data heap references to object\n");
+	print_string("refs <addr>      -- find data heap references to object\n");
-	printf("push <addr>      -- push object on data stack - NOT SAFE\n");
+	print_string("push <addr>      -- push object on data stack - NOT SAFE\n");
-	printf("code             -- code heap dump\n");
+	print_string("code             -- code heap dump\n");
 
 	bool seen_command = false;
 
@@ -364,7 +375,7 @@ void factorbug(void)
 	{
 		char cmd[1024];
 
-		printf("READY\n");
+		print_string("READY\n");
 		fflush(stdout);
 
 		if(scanf("%1000s",cmd) <= 0)
@@ -389,23 +400,22 @@ void factorbug(void)
 
 		if(strcmp(cmd,"d") == 0)
 		{
-			CELL addr, count;
+			CELL addr = read_cell_hex();
-			scanf("%lx %lx",&addr,&count);
+			scanf(" ");
+			CELL count = read_cell_hex();
 			dump_memory(addr,addr+count);
 		}
-		if(strcmp(cmd,"u") == 0)
+		else if(strcmp(cmd,"u") == 0)
 		{
-			CELL addr, count;
+			CELL addr = read_cell_hex();
-			scanf("%lx",&addr);
+			CELL count = object_size(addr);
-			count = object_size(addr);
 			dump_memory(addr,addr+count);
 		}
 		else if(strcmp(cmd,".") == 0)
 		{
-			CELL addr;
+			CELL addr = read_cell_hex();
-			scanf("%lx",&addr);
 			print_obj(addr);
-			printf("\n");
+			print_string("\n");
 		}
 		else if(strcmp(cmd,"t") == 0)
 			full_output = !full_output;
@@ -429,15 +439,15 @@ void factorbug(void)
 			dump_generations();
 		else if(strcmp(cmd,"card") == 0)
 		{
-			CELL addr;
+			CELL addr = read_cell_hex();
-			scanf("%lx",&addr);
+			print_cell_hex((CELL)ADDR_TO_CARD(addr));
-			printf("%lx\n",(CELL)ADDR_TO_CARD(addr));
+			nl();
 		}
 		else if(strcmp(cmd,"addr") == 0)
 		{
-			CELL card;
+			CELL card = read_cell_hex();
-			scanf("%lx",&card);
+			print_cell_hex((CELL)CARD_TO_ADDR(card));
-			printf("%lx\n",(CELL)CARD_TO_ADDR(card));
+			nl();
 		}
 		else if(strcmp(cmd,"q") == 0)
 			return;
@@ -449,13 +459,12 @@ void factorbug(void)
 			dump_objects(-1);
 		else if(strcmp(cmd,"refs") == 0)
 		{
-			CELL addr;
+			CELL addr = read_cell_hex();
-			scanf("%lx",&addr);
+			print_string("Data heap references:\n");
-			printf("Data heap references:\n");
 			find_data_references(addr);
-			printf("Code heap references:\n");
+			print_string("Code heap references:\n");
 			find_code_references(addr);
-			printf("\n");
+			nl();
 		}
 		else if(strcmp(cmd,"words") == 0)
 			dump_objects(WORD_TYPE);
@@ -463,20 +472,19 @@ void factorbug(void)
 			dump_objects(TUPLE_TYPE);
 		else if(strcmp(cmd,"push") == 0)
 		{
-			CELL addr;
+			CELL addr = read_cell_hex();
-			scanf("%lx",&addr);
 			dpush(addr);
 		}
 		else if(strcmp(cmd,"code") == 0)
 			dump_heap(&code_heap);
 		else
-			printf("unknown command\n");
+			print_string("unknown command\n");
 	}
 }
 
 void primitive_die(void)
 {
-	fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
+	print_string("The die word was called by the library. Unless you called it yourself,\n");
-	fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
+	print_string("you have triggered a bug in Factor. Please report.\n");
 	factorbug();
 }

vm/errors.c

@@ -2,21 +2,23 @@
 
 void out_of_memory(void)
 {
-	fprintf(stderr,"Out of memory\n\n");
+	print_string("Out of memory\n\n");
 	dump_generations();
 	exit(1);
 }
 
 void fatal_error(char* msg, CELL tagged)
 {
-	fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged);
+	print_string("fatal_error: "); print_string(msg);
+	print_string(": "); print_cell_hex(tagged); nl();
 	exit(1);
 }
 
 void critical_error(char* msg, CELL tagged)
 {
-	fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
+	print_string("You have triggered a bug in Factor. Please report.\n");
-	fprintf(stderr,"critical_error: %s %lx\n",msg,tagged);
+	print_string("critical_error: "); print_string(msg);
+	print_string(": "); print_cell_hex(tagged); nl();
 	factorbug();
 }
 
@@ -57,10 +59,10 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 	crash. */
 	else
 	{
-		printf("You have triggered a bug in Factor. Please report.\n");
+		print_string("You have triggered a bug in Factor. Please report.\n");
-		printf("early_error: ");
+		print_string("early_error: ");
 		print_obj(error);
-		printf("\n");
+		nl();
 		factorbug();
 	}
 }

vm/factor.c

@@ -41,8 +41,8 @@ void default_parameters(F_PARAMETERS *p)
 /* Do some initialization that we do once only */
 void do_stage1_init(void)
 {
-	fprintf(stderr,"*** Stage 2 early init... ");
+	print_string("*** Stage 2 early init... ");
-	fflush(stderr);
+	fflush(stdout);
 
 	CELL words = find_all_words();
 
@@ -65,8 +65,8 @@ void do_stage1_init(void)
 
 	userenv[STAGE2_ENV] = T;
 
-	fprintf(stderr,"done\n");
+	print_string("done\n");
-	fflush(stderr);
+	fflush(stdout);
 }
 
 /* Get things started */

vm/ffi_test.c

@@ -6,91 +6,76 @@
 
 void ffi_test_0(void)
 {
-	printf("ffi_test_0()\n");
 }
 
 int ffi_test_1(void)
 {
-	printf("ffi_test_1()\n");
 	return 3;
 }
 
 int ffi_test_2(int x, int y)
 {
-	printf("ffi_test_2(%d,%d)\n",x,y);
 	return x + y;
 }
 
 int ffi_test_3(int x, int y, int z, int t)
 {
-	printf("ffi_test_3(%d,%d,%d,%d)\n",x,y,z,t);
 	return x + y + z * t;
 }
 
 float ffi_test_4(void)
 {
-	printf("ffi_test_4()\n");
 	return 1.5;
 }
 
 double ffi_test_5(void)
 {
-	printf("ffi_test_5()\n");
 	return 1.5;
 }
 
 double ffi_test_6(float x, float y)
 {
-	printf("ffi_test_6(%f,%f)\n",x,y);
 	return x * y;
 }
 
 double ffi_test_7(double x, double y)
 {
-	printf("ffi_test_7(%f,%f)\n",x,y);
 	return x * y;
 }
 
 double ffi_test_8(double x, float y, double z, float t, int w)
 {
-	printf("ffi_test_8(%f,%f,%f,%f,%d)\n",x,y,z,t,w);
 	return x * y + z * t + w;
 }
 
 int ffi_test_9(int a, int b, int c, int d, int e, int f, int g)
 {
-	printf("ffi_test_9(%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g);
 	return a + b + c + d + e + f + g;
 }
 
 int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h)
 {
-	printf("ffi_test_10(%d,%d,%f,%d,%f,%d,%d,%d)\n",a,b,c,d,e,f,g,h);
 	return a - b - c - d - e - f - g - h;
 }
 
 int ffi_test_11(int a, struct foo b, int c)
 {
-	printf("ffi_test_11(%d,{%d,%d},%d)\n",a,b.x,b.y,c);
 	return a * b.x + c * b.y;
 }
 
 int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
 {
-	printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f);
 	return a + b + c.x + c.y + c.w + c.h + d + e + f;
 }
 
 int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k)
 {
-	printf("ffi_test_13(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g,h,i,j,k);
 	return a + b + c + d + e + f + g + h + i + j + k;
 }
 
 struct foo ffi_test_14(int x, int y)
 {
 	struct foo r;
-	printf("ffi_test_14(%d,%d)\n",x,y);
 	r.x = x; r.y = y;
 	return r;
 }
@@ -119,7 +104,6 @@ struct tiny ffi_test_17(int x)
 
 F_STDCALL int ffi_test_18(int x, int y, int z, int t)
 {
-	printf("ffi_test_18(%d,%d,%d,%d)\n",x,y,z,t);
 	return x + y + z * t;
 }
 
@@ -134,8 +118,6 @@ void ffi_test_20(double x1, double x2, double x3,
 	double y1, double y2, double y3,
 	double z1, double z2, double z3)
 {
-	printf("ffi_test_20(%f,%f,%f,%f,%f,%f,%f,%f,%f)\n",
-		x1, x2, x3, y1, y2, y3, z1, z2, z3);
 }
 
 long long ffi_test_21(long x, long y)
@@ -145,7 +127,6 @@ long long ffi_test_21(long x, long y)
 
 long ffi_test_22(long x, long long y, long long z)
 {
-	printf("ffi_test_22(%ld,%lld,%lld)\n",x,y,z);
 	return x + y / z;
 }
 
@@ -226,13 +207,11 @@ struct test_struct_7 ffi_test_30(void)
 
 int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41)
 {
-	printf("ffi_test_31(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\n",x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32,x33,x34,x35,x36,x37,x38,x39,x40,x41);
 	return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
 }
 
 float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41)
 {
-	printf("ffi_test_31_point_5(%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f)\n",x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32,x33,x34,x35,x36,x37,x38,x39,x40,x41);
 	return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41;
 }
 
@@ -265,17 +244,12 @@ static int global_var;
 
 void ffi_test_36_point_5(void)
 {
-	printf("ffi_test_36_point_5\n");
 	global_var = 0;
 }
 
 int ffi_test_37(int (*f)(int, int, int))
 {
-	printf("ffi_test_37\n");
-	printf("global_var is %d\n",global_var);
 	global_var = f(global_var,global_var * 2,global_var * 3);
-	printf("global_var is %d\n",global_var);
-	fflush(stdout);
 	return global_var;
 }
 
@@ -286,7 +260,6 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
 
 int ffi_test_39(long a, long b, struct test_struct_13 s)
 {
-	printf("ffi_test_39(%ld,%ld,%f,%f,%f,%f,%f,%f)\n",a,b,s.x1,s.x2,s.x3,s.x4,s.x5,s.x6);
 	if(a != b) abort();
 	return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
 }
@@ -296,7 +269,6 @@ struct test_struct_14 ffi_test_40(double x1, double x2)
 	struct test_struct_14 retval;
 	retval.x1 = x1;
 	retval.x2 = x2;
-	printf("ffi_test_40(%f,%f)\n",x1,x2);
 	return retval;
 }
 
@@ -305,7 +277,6 @@ struct test_struct_12 ffi_test_41(int a, double x)
 	struct test_struct_12 retval;
 	retval.a = a;
 	retval.x = x;
-	printf("ffi_test_41(%d,%f)\n",a,x);
 	return retval;
 }
 
@@ -314,7 +285,6 @@ struct test_struct_15 ffi_test_42(float x, float y)
 	struct test_struct_15 retval;
 	retval.x = x;
 	retval.y = y;
-	printf("ffi_test_42(%f,%f)\n",x,y);
 	return retval;
 }
 
@@ -323,7 +293,6 @@ struct test_struct_16 ffi_test_43(float x, int a)
 	struct test_struct_16 retval;
 	retval.x = x;
 	retval.a = a;
-	printf("ffi_test_43(%f,%d)\n",x,a);
 	return retval;
 }
 
@@ -332,6 +301,5 @@ struct test_struct_14 ffi_test_44(void)
 	struct test_struct_14 retval;
 	retval.x1 = 1.0;
 	retval.x2 = 2.0;
-	//printf("ffi_test_44()\n");
 	return retval;
 }

vm/image.c

@@ -28,12 +28,15 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
 
 	F_ZONE *tenured = &data_heap->generations[TENURED];
 
-	long int bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+	F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
 
 	if(bytes_read != h->data_size)
 	{
-		fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
+		print_string("truncated image: ");
-			bytes_read,h->data_size);
+		print_fixnum(bytes_read);
+		print_string(" bytes read, ");
+		print_cell(h->data_size);
+		print_string(" bytes expected\n");
 		fatal_error("load_data_heap failed",0);
 	}
 
@@ -52,11 +55,14 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
 
 	if(h->code_size != 0)
 	{
-		long int bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
+		F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
 		if(bytes_read != h->code_size)
 		{
-			fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
+			print_string("truncated image: ");
-				bytes_read,h->code_size);
+			print_fixnum(bytes_read);
+			print_string(" bytes read, ");
+			print_cell(h->code_size);
+			print_string(" bytes expected\n");
 			fatal_error("load_code_heap failed",0);
 		}
 	}
@@ -72,8 +78,8 @@ void load_image(F_PARAMETERS *p)
 	FILE *file = OPEN_READ(p->image);
 	if(file == NULL)
 	{
-		FPRINTF(stderr,"Cannot open image file: %s\n",p->image);
+		print_string("Cannot open image file: "); print_native_string(p->image); nl();
-		fprintf(stderr,"%s\n",strerror(errno));
+		print_string(strerror(errno)); nl();
 		exit(1);
 	}
 
@@ -106,12 +112,11 @@ bool save_image(const F_CHAR *filename)
 	FILE* file;
 	F_HEADER h;
 
-	FPRINTF(stderr,"*** Saving %s...\n",filename);
-
 	file = OPEN_WRITE(filename);
 	if(file == NULL)
 	{
-		fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
+		print_string("Cannot open image file: "); print_native_string(filename); nl();
+		print_string(strerror(errno)); nl();
 		return false;
 	}
 
@@ -142,19 +147,19 @@ bool save_image(const F_CHAR *filename)
 
 	if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
 	{
-		fprintf(stderr,"Save data heap failed: %s\n",strerror(errno));
+		print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
 		return false;
 	}
 
 	if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
 	{
-		fprintf(stderr,"Save code heap failed: %s\n",strerror(errno));
+		print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
 		return false;
 	}
 
 	if(fclose(file))
 	{
-		fprintf(stderr,"Failed to close image file: %s\n",strerror(errno));
+		print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
 		return false;
 	}
 

vm/main-windows-nt.c

@@ -13,9 +13,9 @@ int WINAPI WinMain(
 	int nArgs;
 
 	szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
-	if( NULL == szArglist )
+	if(NULL == szArglist)
 	{
-		wprintf(L"CommandLineToArgvW failed\n");
+		puts("CommandLineToArgvW failed");
 		return 1;
 	}
 

vm/os-netbsd.h

@@ -2,5 +2,4 @@
 
 #define UAP_PROGRAM_COUNTER(uap)    _UC_MACHINE_PC((ucontext_t *)uap)
 
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
 #define DIRECTORY_P(file) ((file)->d_type == DT_DIR)

vm/os-unix.h

@@ -23,9 +23,21 @@ typedef char F_SYMBOL;
 #define STRNCMP strncmp
 #define STRDUP strdup
 
+#define CELL_FORMAT "%lu"
+#define CELL_HEX_FORMAT "%lx"
+
+#ifdef FACTOR_64
+	#define CELL_HEX_PAD_FORMAT "%016lx"
+#else
+	#define CELL_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%ld"
+
 #define OPEN_READ(path) fopen(path,"rb")
 #define OPEN_WRITE(path) fopen(path,"wb")
-#define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
+
+#define print_native_string(string) print_string(string)
 
 void start_thread(void *(*start_routine)(void *));
 

vm/os-windows.c

@@ -92,7 +92,6 @@ void primitive_existsp(void)
 	BY_HANDLE_FILE_INFORMATION bhfi;
 
 	F_CHAR *path = unbox_u16_string();
-	//wprintf(L"path = %s\n", path);
 	HANDLE h = CreateFileW(path,
 			GENERIC_READ,
 			FILE_SHARE_READ,

vm/os-windows.h

@@ -20,10 +20,22 @@ typedef wchar_t F_CHAR;
 #define STRNCMP wcsncmp
 #define STRDUP _wcsdup
 
+#ifdef WIN64
+        #define CELL_FORMAT "%Iu"
+        #define CELL_HEX_FORMAT "%Ix"
+	#define CELL_HEX_PAD_FORMAT "%016Ix"
+#else
+        #define CELL_FORMAT "%lu"
+        #define CELL_HEX_FORMAT "%lx"
+	#define CELL_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%Id"
+
 #define OPEN_READ(path) _wfopen(path,L"rb")
 #define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define FPRINTF(stream,format,arg) fwprintf(stream,L##format,arg)
 
+#define print_native_string(string) wprintf(L"%s",string)
 
 /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
 #define EPOCH_OFFSET 0x019db1ded53e8000LL

vm/utilities.c

@@ -14,3 +14,42 @@ F_CHAR *safe_strdup(const F_CHAR *str)
 	if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
 	return ptr;
 }
+
+/* We don't use printf directly, because format directives are not portable.
+Instead we define the common cases here. */
+void nl(void)
+{
+	fputs("\n",stdout);
+}
+
+void print_string(const char *str)
+{
+	fputs(str,stdout);
+}
+
+void print_cell(CELL x)
+{
+	printf(CELL_FORMAT,x);
+}
+
+void print_cell_hex(CELL x)
+{
+	printf(CELL_HEX_FORMAT,x);
+}
+
+void print_cell_hex_pad(CELL x)
+{
+	printf(CELL_HEX_PAD_FORMAT,x);
+}
+
+void print_fixnum(F_FIXNUM x)
+{
+	printf(CELL_FORMAT,x);
+}
+
+CELL read_cell_hex(void)
+{
+	CELL cell;
+	scanf(CELL_HEX_FORMAT,&cell);
+	return cell;
+};

vm/utilities.h

@@ -1,2 +1,10 @@
 void *safe_malloc(size_t size);
 F_CHAR *safe_strdup(const F_CHAR *str);
+
+void nl(void);
+void print_string(const char *str);
+void print_cell(CELL x);
+void print_cell_hex(CELL x);
+void print_cell_hex_pad(CELL x);
+void print_fixnum(F_FIXNUM x);
+CELL read_cell_hex(void);