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

README.txt

@@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or
 a terminal listener.
 
 For X11 support, you need recent development libraries for libc,
-Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+Pango, X11, and OpenGL. On a Debian-derived Linux distribution
 (like Ubuntu), you can use the following line to grab everything:
 
-    sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+    sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
 
 If your DISPLAY environment variable is set, the UI will start
 automatically:

basis/db/tester/tester.factor

@@ -3,7 +3,7 @@
 USING: concurrency.combinators db.pools db.sqlite db.tuples
 db.types kernel math random threads tools.test db sequences
 io prettyprint db.postgresql db.sqlite accessors io.files.temp
-namespaces fry system ;
+namespaces fry system math.parser ;
 IN: db.tester
 
 : postgresql-test-db ( -- postgresql-db )
@@ -56,6 +56,10 @@ test-2 "TEST2" {
    { "z" "Z" { VARCHAR 256 } +not-null+ }
 } define-persistent
 
+: test-1-tuple ( -- tuple )
+    f 100 random 100 random 100 random [ number>string ] tri@
+    test-1 boa ;
+
 : db-tester ( test-db -- )
     [
         [
@@ -67,8 +71,7 @@ test-2 "TEST2" {
             drop
             10 [
                 dup [
-                    f 100 random 100 random 100 random test-1 boa
-                    insert-tuple yield
+                    test-1-tuple insert-tuple yield
                 ] with-db
             ] times
         ] with parallel-each
@@ -84,8 +87,7 @@ test-2 "TEST2" {
         <db-pool> [
             10 [
                 10 [
-                    f 100 random 100 random 100 random test-1 boa
-                    insert-tuple yield
+                    test-1-tuple insert-tuple yield
                 ] times
             ] parallel-each
         ] with-pooled-db

basis/editors/emacs/authors.txt

@@ -1 +1,2 @@
 Eduardo Cavazos
+Doug Coleman

basis/editors/emacs/emacs-docs.factor

@@ -2,10 +2,23 @@ USING: help help.syntax help.markup ;
 IN: editors.emacs
 
 ARTICLE: "editors.emacs" "Integration with Emacs"
-"Put this in your " { $snippet ".emacs" } " file:"
+"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:"
 { $code "(server-start)" }
+"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:"
+{ $code "USE: edtiors.emacs"
+        "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global"
+}
+
 "If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
 { $code "(setq server-window 'switch-to-buffer-other-frame)" }
-{ $see-also "editor" } ;
 
-ABOUT: "editors.emacs"
+"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:"
+{ $code "USE: tools.scaffold"
+    "scaffold-emacs"
+}
+
+{ $see-also "editor" }
+
+;
+
+ABOUT: "editors.emacs"

basis/editors/emacs/emacs.factor

@@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ;
 
 : emacsclient ( file line -- )
     [
-        { [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
+        {
+            [ emacsclient-path get-global ]
+            [ default-emacsclient dup emacsclient-path set-global ]
+        } 0|| ,
         "--no-wait" ,
         number>string "+" prepend ,
         ,

basis/io/directories/search/search.factor

@@ -83,15 +83,15 @@ ERROR: file-not-found ;
     ] with-directory ; inline
 
 : directory-size ( path -- n )
-    0 swap t [ file-info size-on-disk>> + ] each-file ;
+    0 swap t [ link-info size-on-disk>> + ] each-file ;
 
-: path>sizes ( path -- assoc )
+: directory-usage ( path -- assoc )
     [
         [
             [ name>> dup ] [ directory? ] bi [
                 directory-size
             ] [
-                file-info size-on-disk>>
+                link-info size-on-disk>>
             ] if
         ] { } map>assoc
     ] with-qualified-directory-entries sort-values ;

basis/io/encodings/8-bit/8-bit-tests.factor

@@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests
 
 [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
 [ { 256 } >string latin1 encode ] must-fail
-[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test
 
 [ "bar" ] [ "bar" latin1 decode ] unit-test
-[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
-[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
+[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
 
 [ t ] [ \ latin1 8-bit-encoding? ] unit-test
 [ "bar" ] [ "bar" \ latin1 decode ] unit-test

basis/io/encodings/ascii/ascii-tests.factor

@@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests
 
 [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
 [ { 128 } >string ascii encode ] must-fail
-[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
+[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test
 
 [ "bar" ] [ "bar" ascii decode ] unit-test
-[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
+[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test

basis/io/encodings/gb18030/gb18030-tests.factor

@@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests
 [ "hello" ] [ "hello" gb18030 encode >string ] unit-test
 [ "hello" ] [ "hello" gb18030 decode ] unit-test
 [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ]
-[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test
+[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test
 [ { HEX: B7 HEX: B8 } ]
 [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test
 [ { HEX: B7 CHAR: replacement-character } ]
@@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests
 [ { HEX: B7 } ]
 [ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test
 [ { CHAR: replacement-character } ]
-[ B{ HEX: A1 } gb18030 decode >array ] unit-test
+[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test
 [ { HEX: 44D7 HEX: 464B } ]
 [ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 }
   gb18030 decode >array ] unit-test
 [ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ]
-[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test
+[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test

basis/io/encodings/utf16/utf16-tests.factor

@@ -1,25 +1,25 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel tools.test io.encodings.utf16 arrays sbufs
-io.streams.byte-array sequences io.encodings io
+io.streams.byte-array sequences io.encodings io strings
 io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf16.tests
 
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
 
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test
 
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
+[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test
 
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test
 
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
 
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test

basis/io/encodings/utf32/utf32-tests.factor

@@ -1,30 +1,30 @@
 ! Copyright (C) 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel tools.test io.encodings.utf32 arrays sbufs
-io.streams.byte-array sequences io.encodings io
+io.streams.byte-array sequences io.encodings io strings
 io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf32.tests
 
-[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test
 [ { } ] [ { } utf32be decode >array ] unit-test
 
-[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
+[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test
 
-[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
-[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
+[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test
+[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test
 [ { } ] [ { } utf32le decode >array ] unit-test
 
-[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
+[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test
 
-[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
-[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
 
-[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test
+[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test
 

basis/io/files/info/unix/unix.factor

@@ -63,6 +63,8 @@ M: unix link-info ( path -- info )
 
 M: unix new-file-info ( -- class ) unix-file-info new ;
 
+CONSTANT: standard-unix-block-size 512
+
 M: unix stat>file-info ( stat -- file-info )
     [ new-file-info ] dip
     {
@@ -80,7 +82,7 @@ M: unix stat>file-info ( stat -- file-info )
         [ stat-st_rdev >>rdev ]
         [ stat-st_blocks >>blocks ]
         [ stat-st_blksize >>blocksize ]
-        [ drop dup [ blocks>> ] [ blocksize>> ] bi * >>size-on-disk ]
+        [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
     } cleave ;
 
 : n>file-type ( n -- type )

basis/io/files/windows/nt/nt.factor

@@ -4,7 +4,7 @@ io.backend.windows io.files.windows io.encodings.utf16n windows
 windows.kernel32 kernel libc math threads system environment
 alien.c-types alien.arrays alien.strings sequences combinators
 combinators.short-circuit ascii splitting alien strings assocs
-namespaces make accessors tr windows.time ;
+namespaces make accessors tr windows.time windows.shell32 ;
 IN: io.files.windows.nt
 
 M: winnt cwd
@@ -58,4 +58,9 @@ M: winnt open-append
     [ dup windows-file-size ] [ drop 0 ] recover
     [ (open-append) ] dip >>ptr ;
 
-M: winnt home "USERPROFILE" os-env ;
+M: winnt home
+    {
+        [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
+        [ "USERPROFILE" os-env ]
+        [ my-documents ]
+    } 0|| ;

basis/io/streams/byte-array/byte-array-tests.factor

@@ -1,11 +1,11 @@
 USING: tools.test io.streams.byte-array io.encodings.binary
 io.encodings.utf8 io kernel arrays strings namespaces ;
 
-[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
 
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
 [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
 
 [ B{ 121 120 } 0 ] [

basis/io/streams/string/string.factor

@@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ;
     512 <sbuf> ;
 
 : with-string-writer ( quot -- str )
-    <string-writer> swap [ output-stream get ] compose with-output-stream*
-    >string ; inline
+    <string-writer> [
+        swap with-output-stream*
+    ] keep >string ; inline

basis/smtp/smtp.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
+! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
 ! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings.string io.encodings.utf8
-io.encodings.iana io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators splitting
-assocs strings math.order math.parser random system calendar summary
-calendar.format accessors sets hashtables base64 debugger classes
-prettyprint io.crlf words ;
+USING: arrays namespaces make io io.encodings io.encodings.string
+io.encodings.utf8 io.encodings.iana io.encodings.binary
+io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
+kernel logging sequences combinators splitting assocs strings
+math.order math.parser random system calendar summary calendar.format
+accessors sets hashtables base64 debugger classes prettyprint words ;
 IN: smtp
 
 SYMBOL: smtp-domain
@@ -88,8 +88,9 @@ M: message-contains-dot summary ( obj -- string )
     [ message-contains-dot ] when ;
 
 : send-body ( email -- )
-    [ body>> ] [ encoding>> ] bi encode
-    >base64-lines write crlf
+    binary encode-output
+    [ body>> ] [ encoding>> ] bi encode >base64-lines write
+    ascii encode-output crlf
     "." command ;
 
 : quit ( -- )

basis/tools/profiler/profiler-docs.factor

@@ -23,7 +23,7 @@ $nl
 { $subsection vocabs-profile. }
 { $subsection method-profile. }
 { $subsection "profiler-limitations" }
-{ $see-also "ui-profiler" } ;
+{ $see-also "ui.tools.profiler" } ;
 
 ABOUT: "profiling"
 

build-support/factor.sh

@@ -22,6 +22,13 @@ test_program_installed() {
     return 1;
 }
 
+exit_script() {
+    if [[ $FIND_MAKE_TARGET -eq true ]] ; then
+		echo $MAKE_TARGET;
+	fi
+	exit $1
+}
+
 ensure_program_installed() {
     installed=0;
     for i in $* ;
@@ -43,7 +50,7 @@ ensure_program_installed() {
             $ECHO -n "any of [ $* ]"
         fi
         $ECHO " and try again."
-        exit 1
+        exit_script 1;
     fi
 }
 
@@ -51,7 +58,7 @@ check_ret() {
     RET=$?
     if [[ $RET -ne 0 ]] ; then
        $ECHO $1 failed
-       exit 2
+       exit_script 2
     fi
 }
 
@@ -62,7 +69,7 @@ check_gcc_version() {
     if [[ $GCC_VERSION == *3.3.* ]] ; then
         $ECHO "You have a known buggy version of gcc (3.3)"
         $ECHO "Install gcc 3.4 or higher and try again."
-        exit 3
+        exit_script 3
     elif [[ $GCC_VERSION == *4.3.* ]] ; then
        MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
     fi
@@ -154,7 +161,7 @@ check_factor_exists() {
     if [[ -d "factor" ]] ; then
         $ECHO "A directory called 'factor' already exists."
         $ECHO "Rename or delete it and try again."
-        exit 4
+        exit_script 4
     fi
 }
 
@@ -279,7 +286,7 @@ check_os_arch_word() {
         $ECHO "OS, ARCH, or WORD is empty.  Please report this."
 
         echo $MAKE_TARGET
-        exit 5
+        exit_script 5
     fi
 }
 
@@ -385,7 +392,7 @@ check_makefile_exists() {
         echo "You are likely in the wrong directory."
         echo "Run this script from your factor directory:"
         echo "     ./build-support/factor.sh"
-        exit 6
+        exit_script 6
     fi
 }
 
@@ -536,6 +543,6 @@ case "$1" in
     bootstrap) get_config_info; bootstrap ;;
     report) find_build_info ;;
     net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
-    make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
+    make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;;
     *) usage ;;
 esac

core/io/encodings/utf8/utf8-tests.factor

@@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests
     utf8 decode >array ;
 
 : encode-utf8-w/stream ( array -- newarray )
-    utf8 encode >array ;
+    >string utf8 encode >array ;
 
 [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test
 

extra/sandbox/authors.txt

@@ -0,0 +1 @@
+Maxim Savchenko

extra/sandbox/sandbox-tests.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+       combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+    H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+    parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+    5
+    {
+        "! Simple factorial example"
+        "APPLYING: kernel math sequences ;"
+        "1 swap [ 1+ * ] each"
+    } run-script
+] unit-test
+
+[
+    5
+    {
+        "! Jailbreak attempt with USE:"
+        "USE: io"
+        "\"Hello world!\" print"
+    } run-script
+]
+[
+    {
+        [ lexer-error? ]
+        [ error>> condition? ]
+        [ error>> error>> no-word-error? ]
+        [ error>> error>> name>> "USE:" = ]
+    } 1&&
+] must-fail-with
+
+[
+    5
+    {
+        "! Jailbreak attempt with unauthorized APPLY:"
+        "APPLY: io"
+        "\"Hello world!\" print"
+    } run-script
+]
+[
+    {
+        [ lexer-error? ]
+        [ error>> sandbox-error? ]
+        [ error>> vocab>> "io" = ]
+    } 1&&
+] must-fail-with

extra/sandbox/sandbox.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+       combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+    "sandbox.syntax" load-vocab vocab-words 1vector
+    use [ auto-use? off call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+    whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+    [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;

extra/sandbox/summary.txt

@@ -0,0 +1 @@
+Basic sandboxing

extra/sandbox/syntax/syntax.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+    dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+    ! #!
+    HEX: OCT: BIN: f t CHAR: "
+    [ { T{
+    ] } ;
+
+REVEAL: ;

extra/sequence-parser/sequence-parser-tests.factor

@@ -1,4 +1,5 @@
-USING: tools.test sequence-parser ascii kernel accessors ;
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
 IN: sequence-parser.tests
 
 [ "hello" ]
@@ -189,3 +190,15 @@ IN: sequence-parser.tests
 
 [ "123u" ]
 [ "123u" <sequence-parser> take-c-integer ] unit-test
+
+[ 36 ]
+[
+    "    //jofiejoe\n    //eoieow\n/*asdf*/\n      "
+    <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test

extra/sequence-parser/sequence-parser.factor

@@ -52,7 +52,7 @@ TUPLE: sequence-parser sequence n ;
     ] [
         [ drop n>> ]
         [ skip-until ]
-        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+        [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
     ] if ; inline
 
 : take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
@@ -104,6 +104,45 @@ TUPLE: sequence-parser sequence n ;
 : skip-whitespace ( sequence-parser -- sequence-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+    [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+    [
+        dup "/*" take-sequence [
+            "*/" take-until-sequence*
+        ] [
+            drop f
+        ] if
+    ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+    [
+        dup "//" take-sequence [
+            [
+                [
+                    { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+                ] take-until
+            ] [
+                advance drop
+            ] bi
+        ] [
+            drop f
+        ] if
+    ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+    skip-whitespace-eol
+    {
+        { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+        { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+        [ ]
+    } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+    skip-whitespace/comments
+    [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
 : take-rest-slice ( sequence-parser -- sequence/f )
     [ sequence>> ] [ n>> ] bi
     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
@@ -157,30 +196,6 @@ TUPLE: sequence-parser sequence n ;
         sequence-parser [ n + ] change-n drop
     ] if ;
 
-: take-c-comment ( sequence-parser -- seq/f )
-    [
-        dup "/*" take-sequence [
-            "*/" take-until-sequence*
-        ] [
-            drop f
-        ] if
-    ] with-sequence-parser ;
-
-: take-c++-comment ( sequence-parser -- seq/f )
-    [
-        dup "//" take-sequence [
-            [
-                [
-                    { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
-                ] take-until
-            ] [
-                advance drop
-            ] bi
-        ] [
-            drop f
-        ] if
-    ] with-sequence-parser ;
-
 : c-identifier-begin? ( ch -- ? )
     CHAR: a CHAR: z [a,b]
     CHAR: A CHAR: Z [a,b]
@@ -192,29 +207,30 @@ TUPLE: sequence-parser sequence n ;
     CHAR: 0 CHAR: 9 [a,b]
     { CHAR: _ } 4 nappend member? ;
 
-: take-c-identifier ( state-parser -- string/f )
-    [
-        dup current c-identifier-begin? [
-            [ current c-identifier-ch? ] take-while
-        ] [
-            drop f
-        ] if
-    ] with-sequence-parser ;
+: (take-c-identifier) ( sequence-parser -- string/f )
+    dup current c-identifier-begin? [
+        [ current c-identifier-ch? ] take-while
+    ] [
+        drop f
+    ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+    [ (take-c-identifier) ] with-sequence-parser ;
 
 << "length" [ length ] define-sorting >>
 
 : sort-tokens ( seq -- seq' )
     { length>=< <=> } sort-by ;
 
-: take-first-matching ( state-parser seq -- seq )
+: take-first-matching ( sequence-parser seq -- seq )
     swap
     '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 
 
-: take-longest ( state-parser seq -- seq )
+: take-longest ( sequence-parser seq -- seq )
     sort-tokens take-first-matching ;
 
-: take-c-integer ( state-parser -- string/f )
+: take-c-integer ( sequence-parser -- string/f )
     [
         dup take-integer [
             swap
@@ -225,5 +241,19 @@ TUPLE: sequence-parser sequence n ;
         ] if*
     ] with-sequence-parser ;
 
+CONSTANT: c-punctuators
+    {
+        "[" "]" "(" ")" "{" "}" "." "->"
+        "++" "--" "&" "*" "+" "-" "~" "!"
+        "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+        "?" ":" ";" "..."
+        "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+        "," "#" "##"
+        "<:" ":>" "<%" "%>" "%:" "%:%:"
+    }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+    c-punctuators take-longest ;
+
 : write-full ( sequence-parser -- ) sequence>> write ;
 : write-rest ( sequence-parser -- ) take-rest write ;