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

basis/bootstrap/image/image.factor

@@ -23,7 +23,7 @@ IN: bootstrap.image
     os name>> cpu name>> arch ;
 
 : boot-image-name ( arch -- string )
-    "boot." swap ".image" 3append ;
+    "boot." ".image" surround ;
 
 : my-boot-image-name ( -- string )
     my-arch boot-image-name ;

basis/calendar/calendar-docs.factor

@@ -99,48 +99,6 @@ HELP: seconds-per-year
 { $values { "integer" integer } }
 { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
 
-HELP: biweekly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of two week periods in a year." } ;
-
-HELP: daily-360
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of days in a 360-day year." } ;
-
-HELP: daily-365
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of days in a 365-day year." } ;
-
-HELP: monthly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of months in a year." } ;
-
-HELP: semimonthly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
-
-HELP: weekly
-{ $values
-     { "x" number }
-     { "y" number }
-}
-{ $description "Divides a number by the number of weeks in a year." } ;
-
 HELP: julian-day-number
 { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
 { $description "Calculates the Julian day number from a year, month, and day.  The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
@@ -582,8 +540,6 @@ ARTICLE: "calendar" "Calendar"
 { $subsection "years" }
 { $subsection "months" }
 { $subsection "days" }
-"Calculating amounts per period of time:"
-{ $subsection "time-period-calculations" }
 "Meta-data about the calendar:"
 { $subsection "calendar-facts" }
 ;
@@ -670,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts"
 { $subsection day-of-week }
 ;
 
-ARTICLE: "time-period-calculations" "Calculations over periods of time"
-{ $subsection monthly }
-{ $subsection semimonthly }
-{ $subsection biweekly }
-{ $subsection weekly }
-{ $subsection daily-360 }
-{ $subsection daily-365 }
-{ $subsection biweekly }
-{ $subsection biweekly }
-{ $subsection biweekly }
-;
-
 ARTICLE: "years" "Year operations"
 "Leap year predicate:"
 { $subsection leap-year? }

basis/calendar/calendar-tests.factor

@@ -167,5 +167,3 @@ IN: calendar.tests
 [ t ] [ now 50 milliseconds sleep now before? ] unit-test
 [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
 [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
-
-[ 4+1/6 ] [ 100 semimonthly ] unit-test

basis/calendar/calendar.factor

@@ -89,13 +89,6 @@ PRIVATE>
 : minutes-per-year ( -- ratio ) 5259492/10 ; inline
 : seconds-per-year ( -- integer ) 31556952 ; inline
 
-: monthly ( x -- y ) 12 / ; inline
-: semimonthly ( x -- y ) 24 / ; inline
-: biweekly ( x -- y ) 26 / ; inline
-: weekly ( x -- y ) 52 / ; inline
-: daily-360 ( x -- y ) 360 / ; inline
-: daily-365 ( x -- y ) 365 / ; inline
-
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800

basis/db/sqlite/sqlite.factor

@@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
 
 M: sqlite-db bind# ( spec obj -- )
     [
-        [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+        [ column-name>> ":" next-sql-counter surround dup 0% ]
         [ type>> ] bi
     ] dip <literal-bind> 1, ;
 

basis/html/elements/elements.factor

@@ -26,7 +26,7 @@ SYMBOL: html
     #! dynamically creating words.
     [ elements-vocab create ] 2dip define-declared ;
 
-: <foo> ( str -- <str> ) "<" swap ">" 3append ;
+: <foo> ( str -- <str> ) "<" ">" surround ;
 
 : def-for-html-word-<foo> ( name -- )
     #! Return the name and code for the <foo> patterned
@@ -49,14 +49,14 @@ SYMBOL: html
     #! word.
     foo> [ ">" write-html ] (( -- )) html-word ;
 
-: </foo> ( str -- </str> ) "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" ">" surround ;
 
 : def-for-html-word-</foo> ( name -- )
     #! Return the name and code for the </foo> patterned
     #! word.
     </foo> dup '[ _ write-html ] (( -- )) html-word ;
 
-: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
 
 : def-for-html-word-<foo/> ( name -- )
     #! Return the name and code for the <foo/> patterned

basis/io/unix/files/macosx/macosx.factor

@@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
     f <void*> dup 0 getmntinfo64 dup io-error
     [ *void* ] dip
     "statfs64" heap-size [ * memory>byte-array ] keep group
-    [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+    [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
+    ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
 
 M: macosx new-file-system-info macosx-file-system-info new ;
 

basis/io/windows/launcher/launcher.factor

@@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
 
 : escape-argument ( str -- newstr )
     CHAR: \s over member? [
-        "\"" swap fix-trailing-backslashes "\"" 3append
+        fix-trailing-backslashes "\"" dup surround
     ] when ;
 
 : join-arguments ( args -- cmd-line )

basis/prettyprint/backend/backend.factor

@@ -10,7 +10,7 @@ IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
 
-M: effect pprint* effect>string "(" swap ")" 3append text ;
+M: effect pprint* effect>string "(" ")" surround text ;
 
 : ?effect-height ( word -- n )
     stack-effect [ effect-height ] [ 0 ] if* ;

basis/smtp/smtp.factor

@@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
     [ bad-email-address ] unless ;
 
 : mail-from ( fromaddr -- )
-    "MAIL FROM:<" swap validate-address ">" 3append command ;
+    validate-address
+    "MAIL FROM:<" ">" surround command ;
 
 : rcpt-to ( to -- )
-    "RCPT TO:<" swap validate-address ">" 3append command ;
+    validate-address
+    "RCPT TO:<" ">" surround command ;
 
 : data ( -- )
     "DATA" command ;

basis/tools/vocabs/browser/browser.factor

@@ -289,7 +289,7 @@ M: vocab-spec article-parent drop "vocab-index" ;
 M: vocab-tag >link ;
 
 M: vocab-tag article-title
-    name>> "Vocabularies tagged ``" swap "''" 3append ;
+    name>> "Vocabularies tagged ``" "''" surround ;
 
 M: vocab-tag article-name name>> ;
 

basis/ui/freetype/freetype.factor

@@ -61,7 +61,7 @@ M: freetype-renderer free-fonts ( world -- )
     } at ;
 
 : ttf-path ( name -- string )
-    "resource:fonts/" swap ".ttf" 3append ;
+    "resource:fonts/" ".ttf" surround ;
 
 : (open-face) ( path length -- face )
     #! We use FT_New_Memory_Face, not FT_New_Face, since

basis/ui/tools/deploy/deploy.factor

@@ -119,5 +119,5 @@ deploy-gadget "toolbar" f {
 : deploy-tool ( vocab -- )
     vocab-name
     [ <deploy-gadget> 10 <border> ]
-    [ "Deploying \"" swap "\"" 3append ] bi
+    [ "Deploying \"" "\"" surround ] bi
     open-window ;

basis/unicode/case/case-tests.factor

@@ -16,3 +16,9 @@ USING: unicode.case tools.test namespaces ;
     "lt" locale set
     ! Lithuanian casing tests
 ] with-scope
+
+[ t ] [ "asdf" lower? ] unit-test
+[ f ] [ "asdF" lower? ] unit-test
+
+[ t ] [ "ASDF" upper? ] unit-test
+[ f ] [ "ASDf" upper? ] unit-test

basis/unicode/case/case.factor

@@ -100,11 +100,10 @@ SYMBOL: locale ! Just casing locale, or overall?
 : >case-fold ( string -- fold )
     >upper >lower ;
 
-: lower? ( string -- ? )
+: lower? ( string -- ? ) dup >lower = ;
-    dup >lower = ;
+
-: upper? ( string -- ? )
+: upper? ( string -- ? ) dup >upper = ;
-    dup >lower = ;
+
-: title? ( string -- ? )
+: title? ( string -- ? ) dup >title = ;
-    dup >title = ;
+
-: case-fold? ( string -- ? )
+: case-fold? ( string -- ? ) dup >case-fold = ;
-    dup >case-fold = ;

core/classes/intersection/intersection.factor

@@ -12,7 +12,7 @@ PREDICATE: intersection-class < class
         [ drop t ]
     ] [
         unclip "predicate" word-prop swap [
-            "predicate" word-prop [ dup ] swap [ not ] 3append
+            "predicate" word-prop [ dup ] [ not ] surround
             [ drop f ]
         ] { } map>assoc alist>quot
     ] if-empty ;

core/parser/parser.factor

@@ -71,7 +71,7 @@ TUPLE: no-current-vocab ;
 
 : word-restarts ( name possibilities -- restarts )
     natural-sort
-    [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
+    [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
     swap "Defer word in current vocabulary" swap 2array
     suffix ;
 
@@ -89,7 +89,7 @@ SYMBOL: auto-use?
         dup vocabulary>>
         [ (use+) ]
         [ amended-use get dup [ push ] [ 2drop ] if ]
-        [ "Added ``" swap "'' vocabulary to search path" 3append note. ]
+        [ "Added ``" "'' vocabulary to search path" surround note. ]
         tri
     ] [ create-in ] if ;
 
@@ -292,7 +292,7 @@ print-use-hook global [ [ ] or ] change-at
     ] with-compilation-unit ;
 
 : parse-file-restarts ( file -- restarts )
-    "Load " swap " again" 3append t 2array 1array ;
+    "Load " " again" surround t 2array 1array ;
 
 : parse-file ( file -- quot )
     [

core/slots/slots.factor

@@ -50,7 +50,7 @@ PREDICATE: writer < word "writer" word-prop ;
     define-typecheck ;
 
 : writer-word ( name -- word )
-    "(>>" swap ")" 3append (( value object -- )) create-accessor
+    "(>>" ")" surround (( value object -- )) create-accessor
     dup t "writer" set-word-prop ;
 
 ERROR: bad-slot-value value class ;

core/words/words.factor

@@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
     dup [ 2nip ] [ drop <word> dup reveal ] if ;
 
 : constructor-word ( name vocab -- word )
-    [ "<" swap ">" 3append ] dip create ;
+    [ "<" ">" surround ] dip create ;
 
 PREDICATE: parsing-word < word "parsing" word-prop ;
 

extra/combinators/lib/lib-tests.factor

@@ -16,7 +16,7 @@ IN: combinators.lib.tests
 
 [ { "foo" "xbarx" } ]
 [
-    { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
+    { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
 ] unit-test
 
 { 1 1 } [

extra/crypto/barrett/barrett.factor

@@ -8,5 +8,3 @@ IN: crypto.barrett
     #! size = word size in bits (8, 16, 32, 64, ...)
     [ [ log2 1+ ] [ / 2 * ] bi* ]
     [ 2^ rot ^ swap /i ] 2bi ;
-
-

extra/crypto/hmac/hmac.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators checksums checksums.md5
 checksums.sha1 checksums.md5.private io io.binary io.files
 io.streams.byte-array kernel math math.vectors memoize sequences

extra/crypto/timing/timing.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math threads system calendar ;
 IN: crypto.timing
 

extra/crypto/xor/xor.factor

@@ -8,5 +8,5 @@ IN: crypto.xor
 ERROR: empty-xor-key ;
 
 : xor-crypt ( seq key -- seq' )
-    dup empty? [ empty-xor-key ] when
+    [ empty-xor-key ] when-empty
     [ dup length ] dip '[ _ mod-nth bitxor ] 2map ;

extra/html/parser/utils/utils.factor

@@ -16,10 +16,10 @@ IN: html.parser.utils
     [ ?head drop ] [ ?tail drop ] bi ;
 
 : single-quote ( str -- newstr )
-    "'" swap "'" 3append ;
+    "'" dup surround ;
 
 : double-quote ( str -- newstr )
-    "\"" swap "\"" 3append ;
+    "\"" dup surround ;
 
 : quote ( str -- newstr )
     CHAR: ' over member?

extra/inverse/inverse.factor

@@ -9,14 +9,12 @@ combinators.short-circuit fry qualified ;
 RENAME: _ fry => __
 IN: inverse
 
-TUPLE: fail ;
+ERROR: fail ;
-: fail ( -- * ) \ fail new throw ;
 M: fail summary drop "Unification failed" ;
 
 : assure ( ? -- ) [ fail ] unless ;
 
-: =/fail ( obj1 obj2 -- )
+: =/fail ( obj1 obj2 -- ) = assure ;
-    = assure ;
 
 ! Inverse of a quotation
 
@@ -26,25 +24,26 @@ M: fail summary drop "Unification failed" ;
     pick 1quotation 3array "math-inverse" set-word-prop ;
 
 : define-pop-inverse ( word n quot -- )
-    >r dupd "pop-length" set-word-prop r>
+    [ dupd "pop-length" set-word-prop ] dip
     "pop-inverse" set-word-prop ;
 
-TUPLE: no-inverse word ;
+ERROR: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse new throw ;
 M: no-inverse summary
     drop "The word cannot be used in pattern matching" ;
 
+ERROR: bad-math-inverse ;
+
 : next ( revquot -- revquot* first )
-    [ "Badly formed math inverse" throw ]
+    [ bad-math-inverse ]
     [ unclip-slice ] if-empty ;
 
 : constant-word? ( word -- ? )
     stack-effect
-    [ out>> length 1 = ] keep
+    [ out>> length 1 = ]
-    in>> length 0 = and ;
+    [ in>> empty? ] bi and ;
 
 : assure-constant ( constant -- quot )
-    dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
+    dup word? [ bad-math-inverse ] when 1quotation ;
 
 : swap-inverse ( math-inverse revquot -- revquot* quot )
     next assure-constant rot second '[ @ swap @ ] ;
@@ -55,8 +54,7 @@ M: no-inverse summary
 : ?word-prop ( word/object name -- value/f )
     over word? [ word-prop ] [ 2drop f ] if ;
 
-: undo-literal ( object -- quot )
+: undo-literal ( object -- quot ) [ =/fail ] curry ;
-    [ =/fail ] curry ;
 
 PREDICATE: normal-inverse < word "inverse" word-prop ;
 PREDICATE: math-inverse < word "math-inverse" word-prop ;
@@ -65,13 +63,13 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : enough? ( stack word -- ? )
     dup deferred? [ 2drop f ] [
-        [ >r length r> 1quotation infer in>> >= ]
+        [ [ length ] dip 1quotation infer in>> >= ]
         [ 3drop f ] recover
     ] if ;
 
 : fold-word ( stack word -- stack )
     2dup enough?
-    [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
+    [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
 
 : fold ( quot -- folded-quot )
     [ { } swap [ fold-word ] each % ] [ ] make ; 
@@ -95,13 +93,15 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
         throw
     ] recover ;
 
+ERROR: undefined-inverse ;
+
 GENERIC: inverse ( revquot word -- revquot* quot )
 
 M: object inverse undo-literal ;
 
 M: symbol inverse undo-literal ;
 
-M: word inverse drop "Inverse is undefined" throw ;
+M: word inverse undefined-inverse ;
 
 M: normal-inverse inverse
     "inverse" word-prop ;
@@ -112,8 +112,8 @@ M: math-inverse inverse
     [ drop swap-inverse ] [ pull-inverse ] if ;
 
 M: pop-inverse inverse
-    [ "pop-length" word-prop cut-slice swap >quotation ] keep
+    [ "pop-length" word-prop cut-slice swap >quotation ]
-    "pop-inverse" word-prop compose call ;
+    [ "pop-inverse" word-prop ] bi compose call ;
 
 : (undo) ( revquot -- )
     [ unclip-slice inverse % (undo) ] unless-empty ;
@@ -129,7 +129,7 @@ MACRO: undo ( quot -- ) [undo] ;
 \ dup [ [ =/fail ] keep ] define-inverse
 \ 2dup [ over =/fail over =/fail ] define-inverse
 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
-\ pick [ >r pick r> =/fail ] define-inverse
+\ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
 \ not [ not ] define-inverse
@@ -151,9 +151,12 @@ MACRO: undo ( quot -- ) [undo] ;
 \ sq [ sqrt ] define-inverse
 \ sqrt [ sq ] define-inverse
 
+ERROR: missing-literal ;
+
 : assert-literal ( n -- n )
-    dup [ word? ] keep symbol? not and
+    dup
-    [ "Literal missing in pattern matching" throw ] when ;
+    [ word? ] [ symbol? not ] bi and
+    [ missing-literal ] when ;
 \ + [ - ] [ - ] define-math-inverse
 \ - [ + ] [ - ] define-math-inverse
 \ * [ / ] [ / ] define-math-inverse
@@ -162,7 +165,7 @@ MACRO: undo ( quot -- ) [undo] ;
 
 \ ? 2 [
     [ assert-literal ] bi@
-    [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
+    [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
     2curry
 ] define-pop-inverse
 
@@ -217,7 +220,7 @@ DEFER: _
     dup wrapper? [ wrapped>> ] when ;
 
 : boa-inverse ( class -- quot )
-    [ deconstruct-pred ] keep slot-readers compose ;
+    [ deconstruct-pred ] [ slot-readers ] bi compose ;
 
 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 
@@ -232,7 +235,7 @@ DEFER: _
 
 : recover-fail ( try fail -- )
     [ drop call ] [
-        >r nip r> dup fail?
+        [ nip ] dip dup fail?
         [ drop call ] [ nip throw ] if
     ] recover ; inline
 
@@ -243,12 +246,11 @@ DEFER: _
     in>> [ ndrop f ] curry [ recover-fail ] curry ;
 
 : [matches?] ( quot -- undoes?-quot )
-    [undo] dup infer [ true-out ] keep false-recover curry ;
+    [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
 
 MACRO: matches? ( quot -- ? ) [matches?] ;
 
-TUPLE: no-match ;
+ERROR: no-match ;
-: no-match ( -- * ) \ no-match new throw ;
 M: no-match summary drop "Fall through in switch" ;
 
 : recover-chain ( seq -- quot )
@@ -256,7 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
 
 : [switch]  ( quot-alist -- quot )
     [ dup quotation? [ [ ] swap 2array ] when ] map
-    reverse [ >r [undo] r> compose ] { } assoc>map
+    reverse [ [ [undo] ] dip compose ] { } assoc>map
     recover-chain ;
 
 MACRO: switch ( quot-alist -- ) [switch] ;

extra/lint/lint-tests.factor

@@ -0,0 +1,14 @@
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+
+[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
+
+: lint2 ( n -- n' ) 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3 dup -rot ; ! tuck
+
+[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test

extra/lint/lint.factor

@@ -0,0 +1,171 @@
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors arrays assocs
+combinators.short-circuit fry hashtables html.elements io
+kernel math namespaces prettyprint quotations sequences
+sequences.deep sets slots.private vectors vocabs words
+kernel.private ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+    2dup at -rot [ ?push ] 2dip set-at ;
+
+: more-defs ( hash -- )
+    {
+        { -rot [ swap >r swap r> ] }
+        { -rot [ swap swapd ] }
+        { rot [ >r swap r> swap ] }
+        { rot [ swapd swap ] }
+        { over [ dup swap ] }
+        { tuck [ dup -rot ] }
+        { swapd [ >r swap r> ] }
+        { 2nip [ nip nip ] }
+        { 2drop [ drop drop ] }
+        { 3drop [ drop drop drop ] }
+        { pop* [ pop drop ] }
+        { when [ [ ] if ] }
+        { >boolean [ f = not ] }
+    } swap '[ first2 _ set-hash-vector ] each ;
+
+: accessor-words ( -- seq )
+{
+    alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+    alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+    <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+    set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+    set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+    set-alien-unsigned-8 set-alien-signed-8
+    alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+    set-alien-float alien-float
+} ;
+
+: trivial-defs
+    {
+        [ . ]
+        [ get ]
+        [ t ] [ f ]
+        [ { } ]
+        [ drop ] ! because of declare
+        [ drop f ]
+        [ "cdecl" ]
+        [ first ] [ second ] [ third ] [ fourth ]
+        [ ">" write-html ] [ "/>" write-html ]
+    } ;
+
+! ! Add definitions
+H{ } clone def-hash set-global
+
+all-words [
+    dup def>> dup callable?
+    [ def-hash get-global set-hash-vector ] [ drop ] if
+] each
+
+! ! Remove definitions
+
+! Remove empty word defs
+def-hash get-global [ drop empty? not ] assoc-filter
+
+! Remove constants [ 1 ]
+[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
+
+! Remove words that are their own definition
+[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
+
+! Remove set-alien-cell, etc.
+[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
+
+! Remove trivial defs
+[ drop trivial-defs member? not ] assoc-filter
+
+! Remove tag defs
+[
+    drop {
+            [ length 3 = ]
+            [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+    } 1&& not
+] assoc-filter
+
+[
+    drop {
+        [ [ wrapper? ] deep-contains? ]
+        [ [ hashtable? ] deep-contains? ]
+    } 1|| not
+] assoc-filter
+
+! Remove n m shift defs
+[
+    drop dup length 3 = [
+        [ first2 [ number? ] both? ]
+        [ third \ shift = ] bi and not
+    ] [ drop t ] if
+] assoc-filter 
+
+! Remove [ n slot ]
+[
+    drop dup length 2 =
+    [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
+] assoc-filter
+
+
+dup more-defs
+
+[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+
+: find-duplicates ( -- seq )
+    def-hash get-global [ nip length 1 > ] assoc-filter ;
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq ) drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+    { [ start ] [ member? ] } 2|| ;
+
+M: callable lint ( quot -- seq )
+    [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+
+M: word lint ( word -- seq )
+    def>> dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+    [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+
+: 4bl ( -- ) bl bl bl bl ;
+
+: (lint.) ( pair -- )
+    first2 [ word-path. ] dip [
+        [ 4bl .  "-----------------------------------" print ]
+        [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
+    ] each nl nl ;
+
+: lint. ( alist -- ) [ (lint.) ] each ;
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self) ( val key -- obj ? )
+    def-hash get-global at*
+    [ dupd remove empty? not ] [ drop f ] if ;
+
+: trim-self ( seq -- newseq )
+    [ [ (trim-self) ] filter ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+    [
+        nip first dup def-hash get-global at
+        [ first ] bi@ literalize = not
+    ] assoc-filter ;
+
+M: sequence run-lint ( seq -- seq )
+    [ dup lint ] { } map>assoc trim-self
+    [ second empty? not ] filter filter-symbols ;
+
+M: word run-lint ( word -- seq ) 1array run-lint ;
+
+: lint-all ( -- seq ) all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+
+: lint-word ( word -- seq ) 1array run-lint dup lint. ;

extra/math/finance/finance-docs.factor

@@ -1,8 +1,6 @@
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license
-
+USING: help.markup help.syntax math ;
-USING: help.markup help.syntax ;
-
 IN: math.finance
 
 HELP: sma
@@ -32,3 +30,59 @@ HELP: momentum
     { $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
 } ;
 
+HELP: biweekly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of two week periods in a year." } ;
+
+HELP: daily-360
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of days in a 360-day year." } ;
+
+HELP: daily-365
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of days in a 365-day year." } ;
+
+HELP: monthly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of months in a year." } ;
+
+HELP: semimonthly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
+
+HELP: weekly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of weeks in a year." } ;
+
+ARTICLE: "time-period-calculations" "Calculations over periods of time"
+{ $subsection monthly }
+{ $subsection semimonthly }
+{ $subsection biweekly }
+{ $subsection weekly }
+{ $subsection daily-360 }
+{ $subsection daily-365 } ;
+
+ARTICLE: "math.finance" "Financial math"
+"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl
+"Calculating payroll over periods of time:"
+{ $subsection "time-period-calculations" } ;
+
+ABOUT: "math.finance"

extra/math/finance/finance-tests.factor

@@ -6,3 +6,4 @@ IN: math.finance.tests
 
 [ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
 
+[ 4+1/6 ] [ 100 semimonthly ] unit-test

extra/math/finance/finance.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 John Benediktsson.
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel grouping sequences shuffle
 math math.functions math.statistics math.vectors ;
@@ -26,3 +26,14 @@ PRIVATE>
 : momentum ( seq n -- newseq )
     [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
 
+: monthly ( x -- y ) 12 / ; inline
+
+: semimonthly ( x -- y ) 24 / ; inline
+
+: biweekly ( x -- y ) 26 / ; inline
+
+: weekly ( x -- y ) 52 / ; inline
+
+: daily-360 ( x -- y ) 360 / ; inline
+
+: daily-365 ( x -- y ) 365 / ; inline

extra/math/numerical-integration/numerical-integration.factor

@@ -4,15 +4,16 @@ USING: arrays kernel sequences namespaces make math math.ranges
 math.vectors vectors ;
 IN: math.numerical-integration
 
-SYMBOL: num-steps 180 num-steps set-global
+SYMBOL: num-steps
+
+180 num-steps set-global
 
 : setup-simpson-range ( from to -- frange )
     2dup swap - num-steps get / <range> ;
 
 : generate-simpson-weights ( seq -- seq )
-    { 1 4 }
+    length 2 / 2 - { 2 4 } <repetition> concat
-    swap length 2 / 2 - { 2 4 } <repetition> concat
+    { 1 4 } { 1 } surround ;
-    { 1 } 3append ;
 
 : integrate-simpson ( from to f -- x )
     [ setup-simpson-range dup ] dip 

extra/multi-methods/multi-methods.factor

@@ -102,7 +102,7 @@ SYMBOL: total
         { 0 [ [ dup ] ] }
         { 1 [ [ over ] ] }
         { 2 [ [ pick ] ] }
-        [ 1- picker [ >r ] swap [ r> swap ] 3append ]
+        [ 1- picker [ >r ] [ r> swap ] surround ]
     } case ;
 
 : (multi-predicate) ( class picker -- quot )

extra/parser-combinators/simple/simple-docs.factor

@@ -41,7 +41,7 @@ HELP: 'bold'
     "commonly used in markup languages to indicate bold "
     "faced text." }
 { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
-{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" \"</strong>\" surround ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
 
 HELP: 'italic'
 { $values 
@@ -53,7 +53,7 @@ HELP: 'italic'
     "faced text." }
 { $examples
 { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
-{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" \"</emphasis>\" surround ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
 HELP: comma-list
 { $values 
   { "element" "a parser object" } { "parser" "a parser object" } }

extra/project-euler/117/117.factor

@@ -27,9 +27,6 @@ IN: project-euler.117
 
 <PRIVATE
 
-: short ( seq n -- seq n )
-    over length min ;
-
 : next ( seq -- )
     [ 4 short tail* sum ] keep push ;
 

extra/raptor/raptor.factor

@@ -32,8 +32,8 @@ SYMBOL: networking-hook
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
+: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ;
-: stop-service  ( name -- ) "/etc/init.d/" swap " stop"  3append system drop ;
+: stop-service  ( name -- ) "/etc/init.d/" " stop"  surround system drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/system-info/backend/backend.factor

@@ -1,5 +1,7 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: system ;
-IN: hardware-info.backend
+IN: system-info.backend
 
 HOOK: cpus os ( -- n )
 HOOK: cpu-mhz os ( -- n )

extra/system-info/linux/linux.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: unix alien alien.c-types kernel math sequences strings
 io.unix.backend splitting ;
-IN: hardware-info.linux
+IN: system-info.linux
 
 : (uname) ( buf -- int )
     "int" f "uname" { "char*" } alien-invoke ;

extra/system-info/macosx/macosx.factor

@@ -1,8 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax
 byte-arrays kernel namespaces sequences unix
-hardware-info.backend system io.unix.backend io.encodings.ascii
+system-info.backend system io.unix.backend io.encodings.utf8 ;
-;
+IN: system-info.macosx
-IN: hardware-info.macosx
 
 ! See /usr/include/sys/sysctl.h for constants
 
@@ -20,7 +21,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
     [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
 
 : sysctl-query-string ( seq -- n )
-    4096 sysctl-query ascii malloc-string ;
+    4096 sysctl-query utf8 alien>string ;
 
 : sysctl-query-uint ( seq -- n )
     4 sysctl-query *uint ;
@@ -53,4 +54,3 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
 : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
 : mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
 : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
-

extra/system-info/system-info.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax kernel math prettyprint io math.parser
-combinators vocabs.loader hardware-info.backend system ;
+combinators vocabs.loader system-info.backend system ;
-IN: hardware-info
+IN: system-info
 
 : write-unit ( x n str -- )
     [ 2^ /f number>string write bl ] [ write ] bi* ;
@@ -11,13 +13,13 @@ IN: hardware-info
 : ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
 
 << {
-    { [ os windows? ] [ "hardware-info.windows" ] }
+    { [ os windows? ] [ "system-info.windows" ] }
-    { [ os linux? ] [ "hardware-info.linux" ] }
+    { [ os linux? ] [ "system-info.linux" ] }
-    { [ os macosx? ] [ "hardware-info.macosx" ] }
+    { [ os macosx? ] [ "system-info.macosx" ] }
     [ f ]
 } cond [ require ] when* >>
 
-: hardware-report. ( -- )
+: system-report. ( -- )
     "CPUs: " write cpus number>string write nl
     "CPU Speed: " write cpu-mhz ghz nl
     "Physical RAM: " write physical-mem megs nl ;

extra/system-info/windows/ce/ce.factor

@@ -1,6 +1,8 @@
-USING: alien.c-types hardware-info kernel math namespaces
+! Copyright (C) 2008 Doug Coleman.
-windows windows.kernel32 hardware-info.backend system ;
+! See http://factorcode.org/license.txt for BSD license.
-IN: hardware-info.windows.ce
+USING: alien.c-types system-info kernel math namespaces
+windows windows.kernel32 system-info.backend system ;
+IN: system-info.windows.ce
 
 : memory-status ( -- MEMORYSTATUS )
     "MEMORYSTATUS" <c-object>

extra/system-info/windows/nt/nt.factor

@@ -1,8 +1,10 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings
-kernel libc math namespaces hardware-info.backend
+kernel libc math namespaces system-info.backend
-hardware-info.windows windows windows.advapi32
+system-info.windows windows windows.advapi32
 windows.kernel32 system byte-arrays ;
-IN: hardware-info.windows.nt
+IN: system-info.windows.nt
 
 M: winnt cpus ( -- n )
     system-info SYSTEM_INFO-dwNumberOfProcessors ;

extra/system-info/windows/windows.factor

@@ -1,8 +1,10 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types kernel libc math namespaces
 windows windows.kernel32 windows.advapi32
-words combinators vocabs.loader hardware-info.backend
+words combinators vocabs.loader system-info.backend
 system alien.strings ;
-IN: hardware-info.windows
+IN: system-info.windows
 
 : system-info ( -- SYSTEM_INFO )
     "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
@@ -65,6 +67,6 @@ IN: hardware-info.windows
 
 <<
 {
-    { [ os wince? ] [ "hardware-info.windows.ce" ] }
+    { [ os wince? ] [ "system-info.windows.ce" ] }
-    { [ os winnt? ] [ "hardware-info.windows.nt" ] }
+    { [ os winnt? ] [ "system-info.windows.nt" ] }
 } cond require >>

extra/taxes/usa/usa-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel money tools.test
 taxes.usa taxes.usa.federal taxes.usa.mn
-calendar taxes.usa.w4 usa-cities ;
+calendar taxes.usa.w4 usa-cities math.finance ;
 IN: taxes.usa.tests
 
 [

extra/webapps/wiki/wiki.factor

@@ -230,7 +230,7 @@ M: revision feed-entry-url id>> revision-url ;
         [ list-revisions ] >>entries ;
 
 : rollback-description ( description -- description' )
-    [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
+    [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ;
 
 : <rollback-action> ( -- action )
     <action>

unmaintained/README.libs.txt

@@ -1,88 +0,0 @@
-This directory contains Factor code that is not part of the core
-library, but is useful enough to ship with the Factor distribution.
-
-Modules can be loaded from the listener:
-
-  "libs/modulename" require
-
-Available libraries:
-
-- alarms -- call a quotation at a calendar date (Doug Coleman)
-- alien -- Alien utility words (Eduardo Cavazos)
-- base64 -- base64 encoding/decoding (Doug Coleman)
-- basic-authentication -- basic authentication implementation for HTTP server (Chris Double)
-- cairo -- cairo bindings (Sampo Vuori)
-- calendar -- timestamp/calendar with timezones (Doug Coleman)
-- canvas -- Gadget which renders an OpenGL display list (Slava Pestov)
-- cocoa-callbacks -- Allows you to use Factor quotations as actions (Slava Pestov)
-- concurrency -- Erlang/Termite-style distibuted concurrency (Chris Double)
-- coroutines -- coroutines (Chris Double)
-- cryptlib -- cryptlib binding (Elie Chaftari)
-- crypto -- Various cryptographic algorithms (Doug Coleman)
-- csv -- Comma-separated values parser (Daniel Ehrenberg)
-- dlists -- double-linked-lists (Mackenzie Straight)
-- editpadpro -- EditPadPro integration for Windows (Ryan Murphy)
-- emacs -- emacs integration (Eduardo Cavazos)
-- farkup -- Wiki-style markup (Matthew Willis)
-- file-appender -- append to existing files (Doug Coleman)
-- fjsc -- Factor to Javascript compiler (Chris Double)
-- furnace -- Web framework (Slava Pestov)
-- gap-buffer -- Efficient text editor buffer (Alex Chapman)
-- graphics -- Graphics library in Factor (Doug Coleman)
-- hardware-info -- Information about your computer (Doug Coleman)
-- handler -- Gesture handler mixin (Eduardo Cavazos)
-- heap -- Binary min heap implementation (Ryan Murphy)
-- hexdump -- Hexdump routine (Doug Coleman)
-- http -- Code shared by HTTP server and client (Slava Pestov)
-- http-client -- HTTP client (Slava Pestov)
-- id3 -- ID3 parser (Adam Wendt)
-- io -- mmap, filesystem utils (Doug Coleman)
-- jedit -- jEdit editor integration (Slava Pestov)
-- jni -- Java Native Interface Wrapper (Chris Double)
-- json -- JSON reader and writer (Chris Double)
-- koszul -- Lie algebra cohomology and central representation (Slava Pestov)
-- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis)
-- locals -- Crappy local variables (Slava Pestov)
-- mad -- Wrapper for libmad MP3 decoder (Adam Wendt)
-- match -- pattern matching (Chris Double)
-- math -- extended math library (Doug Coleman, Slava Pestov)
-- matrices -- Matrix math (Slava Pestov)
-- memoize -- memoization (caching word results) (Slava Pestov)
-- mmap -- memory mapped files (Doug Coleman)
-- mysql -- MySQL binding (Berlin Brown)
-- null-stream -- Something akin to /dev/null (Slava Pestov)
-- odbc -- Wrapper for ODBC library (Chris Double)
-- ogg -- Wrapper for libogg library (Chris Double)
-- openal -- Wrapper for OpenAL and alut sound libraries (Chris Double)
-- oracle -- Oracle binding (Elie Chaftari)
-- parser-combinators -- Haskell-style parser combinators (Chris Double)
-- porter-stemmer -- Porter stemming algorithm (Slava Pestov)
-- postgresql -- PostgreSQL binding (Doug Coleman)
-- process -- Run external programs (Slava Pestov, Doug Coleman)
-- qualified -- Qualified names for words in other vocabularies (Daniel Ehrenberg)
-- rewrite-closures -- Turn quotations into closures (Eduardo Cavazos)
-- scite -- SciTE editor integration (Clemens F. Hofreither)
-- sequences -- Non-core sequence words (Eduardo Cavazos)
-- serialize -- Binary object serialization (Chris Double)
-- server -- The with-server combinator formely found in the core (Slava Pestov)
-- slate -- Framework for graphical demos (Eduardo Cavazos)
-- shuffle -- Shuffle words not in the core library (Chris Double)
-- smtp -- SMTP client library (Elie Chaftari)
-- splay-trees -- Splay trees (Mackenzie Straight)
-- sqlite -- SQLite binding (Chris Double)
-- state-machine -- Finite state machine abstraction (Daniel Ehrenberg)
-- state-parser -- State-based parsing mechanism (Daniel Ehrenberg)
-- textmate -- TextMate integration (Benjamin Pollack)
-- theora -- Wrapper for libtheora library (Chris Double)
-- trees -- Binary search and AVL (balanced) trees (Alex Chapman)
-- usb -- Wrapper for libusb (Chris Double)
-- unicode -- Partial Unicode support beyond the core (Daniel Ehrenberg)
-- units -- Unit conversion (Doug Coleman)
-- vars -- Alternative syntax for variables (Eduardo Cavazos)
-- vim -- VIM integration (Alex Chapman)
-- visitor -- Double dispatch through the visitor pattern (Daniel Ehrenberg)
-- vorbis -- Wrapper for Ogg Vorbis library (Chris Double)
-- x11 -- X Window System client library (Eduardo Cavazos)
-- xml -- XML parser (Daniel Ehrenberg)
-- xml-rpc -- XML-RPC client and server (Daniel Ehrenberg)
-- yahoo -- Yahoo! automated search (Daniel Ehrenberg)

unmaintained/README.txt

@@ -1,30 +0,0 @@
-This directory contains Factor code that is not part of the core
-library, but is useful enough to ship with the Factor distribution.
-
-Modules can be loaded from the listener:
-
-  "apps/modulename" require
-
-Available applications:
-
-- article-manager -- Web-based content management system (Chris Double)
-- automata -- Graphics demo for the UI (Eduardo Cavazos)
-- benchmarks -- Various performance benchmarks (Slava Pestov)
-- boids -- Graphics demo for the UI (Eduardo Cavazos)
-- factory -- X11 window manager (Eduardo Cavazos)
-- furnace-fjsc -- Web frontend for libs/fjsc (Chris Double)
-- furnace-onigiri -- Weblog engine (Matthew Willis)
-- furnace-pastebin -- demo app for Furnace (Slava Pestov)
-- help-lint -- online documentation typo checker (Slava Pestov)
-- icfp-2006 -- implements the icfp 2006 vm, boundvariable.org (Gavin Harrison)
-- http-server -- HTTP server (Slava Pestov, Chris Double)
-- lindenmayer -- L-systems tool (Eduardo Cavazos)
-- lisppaste -- Lisppaste XML-RPC demo (Slava Pestov)
-- ogg-player -- Ogg Vorbis (audio) and Theora (video) player (Chris Double)
-- print-dataflow -- Code to print compiler dataflow IR to the console, or show it in the UI (Slava Pestov)
-- random-tester -- Random compiler tester (Doug Coleman)
-- rss -- An RSS1, RSS2 and Atom parser and aggregator (Chris Double, Daniel Ehrenberg)
-- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double)
-- tetris -- Tetris game (Alex Chapman)
-- turing -- Turing machine demo (Slava Pestov)
-- wee-url -- Web app to make short URLs from long ones (Doug Coleman)

unmaintained/lint/lint-tests.factor

@@ -1,18 +0,0 @@
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
-    [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
-    1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
-    dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-

unmaintained/lint/lint.factor

@@ -1,182 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays assocs
-combinators.lib io kernel macros math namespaces prettyprint
-quotations sequences vectors vocabs words html.elements sets
-slots.private combinators.short-circuit math.order hashtables
-sequences.deep ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
-    2dup at -rot [ ?push ] 2dip set-at ;
-
-: add-word-def ( word quot -- )
-    dup callable? [
-        def-hash get-global set-hash-vector
-    ] [
-        2drop
-    ] if ;
-
-: more-defs ( -- )
-    {
-        { [ swap >r swap r> ] -rot }
-        { [ swap swapd ] -rot }
-        { [ >r swap r> swap ] rot }
-        { [ swapd swap ] rot }
-        { [ dup swap ] over }
-        { [ dup -rot ] tuck }
-        { [ >r swap r> ] swapd }
-        { [ nip nip ] 2nip }
-        { [ drop drop ] 2drop }
-        { [ drop drop drop ] 3drop }
-        { [ 0 = ] zero? }
-        { [ pop drop ] pop* }
-        { [ [ ] if ] when }
-        { [ f = not ] >boolean }
-    } [ first2 swap add-word-def ] each ;
-
-: accessor-words ( -- seq )
-{
-    alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
-    alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
-    <displaced-alien> alien-unsigned-cell set-alien-signed-cell
-    set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
-    set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
-    set-alien-unsigned-8 set-alien-signed-8
-    alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
-    set-alien-float alien-float
-} ;
-
-: trivial-defs
-    {
-        [ get ] [ t ] [ { } ] [ . ] [ drop f ]
-        [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
-        [ ">" write-html ] [ "/>" write-html ]
-    } ;
-
-H{ } clone def-hash set-global
-all-words [ dup def>> add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
-    drop empty? not
-] assoc-filter
-
-! Remove constants [ 1 ]
-[
-    drop { [ length 1 = ] [ first number? ] } 1&& not
-] assoc-filter
-
-! Remove set-alien-cell, etc.
-[
-    drop [ accessor-words diff ] keep [ length ] bi@ =
-] assoc-filter
-
-! Remove trivial defs
-[
-    drop trivial-defs member? not
-] assoc-filter
-
-[
-    drop {
-        [ [ wrapper? ] deep-contains? ]
-        [ [ hashtable? ] deep-contains? ]
-    } 1|| not
-] assoc-filter
-
-! Remove n m shift defs
-[
-    drop dup length 3 = [
-        dup first2 [ number? ] both?
-        swap third \ shift = and not
-    ] [ drop t ] if
-] assoc-filter 
-
-! Remove [ n slot ]
-[
-    drop dup length 2 = [
-        first2 \ slot = swap number? and not
-    ] [ drop t ] if
-] assoc-filter def-hash set-global
-
-: find-duplicates ( -- seq )
-    def-hash get-global [
-        nip length 1 >
-    ] assoc-filter ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
-    drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
-    { [ start ] [ member? ] } 2|| ;
-
-M: callable lint ( quot -- seq )
-    def-hash-keys get [
-        swap subseq/member?
-    ] with filter ;
-
-M: word lint ( word -- seq )
-    def>> dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
-    [ vocabulary>> ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
-    first2 >r word-path. r> [
-        bl bl bl bl
-        dup .
-        "-----------------------------------" print
-        def-hash get at [ bl bl bl bl word-path. ] each
-        nl
-    ] each nl nl ;
-
-: lint. ( alist -- )
-    [ (lint.) ] each ;
-    
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self) ( val key -- obj ? )
-    def-hash get-global at* [
-        dupd remove empty? not
-    ] [
-        drop f
-    ] if ;
-
-: trim-self ( seq -- newseq )
-    [ [ (trim-self) ] filter ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
-    [
-        nip first dup def-hash get at
-        [ first ] bi@ literalize = not
-    ] assoc-filter ;
-
-M: sequence run-lint ( seq -- seq )
-    [
-        global [ dup . flush ] bind
-        dup lint
-    ] { } map>assoc
-    trim-self
-    [ second empty? not ] filter
-    filter-symbols ;
-
-M: word run-lint ( word -- seq )
-    1array run-lint ;
-
-: lint-all ( -- seq )
-    all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq )
-    words run-lint dup lint. ;
-
-: lint-word ( word -- seq )
-    1array run-lint dup lint. ;