diff --git a/CHANGES.txt b/CHANGES.txt index 7ae97b0ba8..72d8a08bb5 100644 --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,8 +1,11 @@ Factor 0.75: ------------ -The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band -data could fill up the buffer and cause a denial-of-service attack. +New generational garbage collector. There are two command line switches +for controlling it: + + +Yn Size of 2 youngest generations, megabytes + +An Size of tenured and semi-spaces, megabytes The alien interface now supports "float" and "double" types. @@ -10,6 +13,26 @@ Defining a predicate subclass of tuple is supported now. Note that unions and complements over tuples are still not supported. Also, predicate subclasses of concrete tuple classes are not supported either. +The seq-each and seq-map words have been renamed to each and map, and +now work with lists. The each and map words in the lists vocabulary have +been removed; use the new generic equivalents instead. + +The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band +data could fill up the buffer and cause a denial-of-service attack. + +Generic words can now dispatch on stack elements other than the top one; +define your generic like this to dispatch on the second element: + + G: foo [ over ] [ type ] ; + +Or this for the third: + + G: foo [ pick ] [ type ] ; + +Note that GENERIC: foo is the same as + + G: foo [ dup ] [ type ] ; + Factor 0.74: ------------ diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index db8266ccce..a01eba61d5 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -6,7 +6,7 @@ http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup - +- investigate if COPYING_GEN needs a fix - alien-global type wrong - simplifier: - dead loads not optimized out @@ -22,8 +22,6 @@ - sleep word - update docs - redo new compiler backend for PowerPC -- type predicates: : foo? type 7 eq? ; -- remove 'not' word, and move t?/f? to kernel - plugin: supportsBackspace - if external factor is down, don't add tons of random shit to the @@ -36,12 +34,10 @@ - nappend: instead of using push, enlarge the sequence with set-length then add set the elements with set-nth - faster sequence operations -- generic each some? all? memq? all=? index? subseq? map +- generic some? all? memq? all=? index? subseq? - index and index* are very slow with lists - unsafe-sbuf>string - generic subseq -- GENERIC: map - - list impl same as now - code walker & exceptions - if two tasks write to a unix stream, the buffer can overflow - rename prettyprint to pprint diff --git a/contrib/cont-responder/eval-responder.factor b/contrib/cont-responder/eval-responder.factor index 92397e6c9a..ad92fafe36 100644 --- a/contrib/cont-responder/eval-responder.factor +++ b/contrib/cont-responder/eval-responder.factor @@ -73,7 +73,7 @@ USE: sequences : escape-quotes ( string -- string ) #! Replace occurrences of single quotes with #! backslash quote. - [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc dup rot ? ] seq-map ; + [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc dup rot ? ] map ; : make-eval-javascript ( string -- string ) #! Give a string return some javascript that when diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index cf1462e8bf..cafaa483ac 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -209,7 +209,7 @@ USE: sequences ] [ drop CHAR: _ ] ifte - ] seq-map ; + ] map ; : is-valid-username? ( username -- bool ) #! Return true if the username parses correctly diff --git a/examples/lcd.factor b/examples/lcd.factor index f21af2b9a5..21a5598300 100644 --- a/examples/lcd.factor +++ b/examples/lcd.factor @@ -8,7 +8,7 @@ USING: sequences kernel math stdio strings ; } nth >r 4 * dup 4 + r> substring ; : lcd-row ( num row -- ) - swap [ CHAR: 0 - over lcd-digit write ] seq-each drop ; + swap [ CHAR: 0 - over lcd-digit write ] each drop ; : lcd ( num -- str ) 3 [ 2dup lcd-row terpri ] repeat drop ; diff --git a/examples/timesheet.factor b/examples/timesheet.factor index 094fbcbe14..cbf1fb016e 100644 --- a/examples/timesheet.factor +++ b/examples/timesheet.factor @@ -36,7 +36,7 @@ strings unparser vectors ; : print-timesheet ( timesheet -- ) "TIMESHEET:" print - [ uncons print-entry ] seq-each ; + [ uncons print-entry ] each ; ! Displaying a menu diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index 32631d4c5f..80b4247e46 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -3,10 +3,14 @@ IN: alien USING: hashtables kernel lists math namespaces parser stdio ; -BUILTIN: dll 15 [ 1 "dll-path" f ] ; -BUILTIN: alien 16 ; -BUILTIN: byte-array 19 ; -BUILTIN: displaced-alien 20 ; +DEFER: dll? +BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ; +DEFER: alien? +BUILTIN: alien 16 alien? ; +DEFER: byte-array? +BUILTIN: byte-array 19 byte-array? ; +DEFER: displaced-alien? +BUILTIN: displaced-alien 20 displaced-alien? ; : NULL ( -- null ) #! C null value. diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 9150699579..31445a8ce4 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -180,7 +180,7 @@ M: f ' ( obj -- ptr ) : fixup-words ( -- ) image get [ dup word? [ fixup-word ] when - ] seq-map image set ; + ] map image set ; M: word ' ( word -- pointer ) transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ; @@ -311,7 +311,7 @@ M: hashtable ' ( hashtable -- pointer ) ] ifte ; : write-image ( image file -- ) - [ [ write-word ] seq-each ] with-stream ; + [ [ write-word ] each ] with-stream ; : with-minimal-image ( quot -- image ) [ diff --git a/library/collections/arrays.factor b/library/collections/arrays.factor index 30a58eab1a..e4e12a3f91 100644 --- a/library/collections/arrays.factor +++ b/library/collections/arrays.factor @@ -17,7 +17,8 @@ DEFER: repeat IN: kernel-internals USING: kernel math-internals sequences ; -BUILTIN: array 8 ; +DEFER: array? +BUILTIN: array 8 array? ; : array-capacity ( a -- n ) 1 slot ; inline : array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline diff --git a/library/collections/assoc.factor b/library/collections/assoc.factor index e9250d3400..f4221056ba 100644 --- a/library/collections/assoc.factor +++ b/library/collections/assoc.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: lists USING: kernel ; +IN: lists USING: kernel sequences ; ! An association list is a list of conses where the car of each ! cons is a key, and the cdr is a value. See the Factor diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 92bfbe397e..af86ca1b6e 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -6,7 +6,9 @@ IN: lists USING: generic kernel sequences ; ! else depends on, and is loaded early in bootstrap. ! lists.factor has everything else. -BUILTIN: cons 2 [ 0 "car" f ] [ 1 "cdr" f ] ; +DEFER: cons? +BUILTIN: cons 2 cons? [ 0 "car" f ] [ 1 "cdr" f ] ; +UNION: general-list f cons ; ! We borrow an idiom from Common Lisp. The car/cdr of an empty ! list is the empty list. @@ -14,6 +16,7 @@ M: f car ; M: f cdr ; GENERIC: >list ( seq -- list ) +M: general-list >list ( list -- list ) ; : swons ( cdr car -- [[ car cdr ]] ) #! Push a new cons cell. If the cdr is f or a proper list, @@ -49,17 +52,11 @@ M: cons peek ( list -- last ) #! Last element of a list. last car ; -UNION: general-list f cons ; - PREDICATE: general-list list ( list -- ? ) #! Proper list test. A proper list is either f, or a cons #! cell whose cdr is a proper list. dup [ last cdr ] when not ; -: with ( obj quot elt -- obj quot ) - #! Utility word for each-with, map-with. - pick pick >r >r swap call r> r> ; inline - : all? ( list pred -- ? ) #! Push if the predicate returns true for each element of #! the list. @@ -79,15 +76,13 @@ PREDICATE: general-list list ( list -- ? ) : (each) ( list quot -- list quot ) [ >r car r> call ] 2keep >r cdr r> ; inline -: each ( list quot -- ) +M: general-list each ( list quot -- ) #! Push each element of a proper list in turn, and apply a #! quotation with effect ( elt -- ) to each element. - over [ (each) each ] [ 2drop ] ifte ; inline + over [ (each) each ] [ 2drop ] ifte ; -: each-with ( obj list quot -- ) - #! Push each element of a proper list in turn, and apply a - #! quotation with effect ( obj elt -- ) to each element. - swap [ with ] each 2drop ; inline +M: cons tree-each ( cons quot -- ) + >r uncons r> tuck >r >r tree-each r> r> tree-each ; : subset ( list quot -- list ) #! Applies a quotation with effect ( X -- ? ) to each diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 2ca2157561..0ce9334855 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -11,7 +11,8 @@ USING: generic kernel lists math sequences vectors ; ! We put hash-size in the hashtables vocabulary, and ! the other words in kernel-internals. -BUILTIN: hashtable 10 +DEFER: hashtable? +BUILTIN: hashtable 10 hashtable? [ 1 "hash-size" set-hash-size ] [ 2 hash-array set-hash-array ] ; diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 976000459b..85465f56b5 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -3,7 +3,8 @@ IN: lists USING: errors generic kernel math sequences ; ! Sequence protocol -M: general-list length 0 swap [ drop 1 + ] each ; +M: f length drop 0 ; +M: cons length cdr length 1 + ; M: f empty? drop t ; M: cons empty? drop f ; @@ -65,17 +66,11 @@ M: general-list contains? ( obj list -- ? ) M: general-list reverse ( list -- list ) [ ] swap [ swons ] each ; -: map ( list quot -- list ) +M: general-list map ( list quot -- list ) #! Push each element of a proper list in turn, and collect #! return values of applying a quotation with effect #! ( X -- Y ) to each element into a new list. - over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline - -: map-with ( obj list quot -- list ) - #! Push each element of a proper list in turn, and collect - #! return values of applying a quotation with effect - #! ( obj elt -- obj ) to each element into a new list. - swap [ with rot ] map 2nip ; inline + over [ (each) rot >r map r> swons ] [ drop ] ifte ; : remove ( obj list -- list ) #! Remove all occurrences of objects equal to this one from diff --git a/library/collections/sbuf.factor b/library/collections/sbuf.factor index 744659151c..8c41dba9b6 100644 --- a/library/collections/sbuf.factor +++ b/library/collections/sbuf.factor @@ -6,7 +6,8 @@ sequences ; M: string (grow) grow-string ; -BUILTIN: sbuf 13 +DEFER: sbuf? +BUILTIN: sbuf 13 sbuf? [ 1 length set-capacity ] [ 2 underlying set-underlying ] ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 5696ea3b79..5aa737c8bb 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -23,38 +23,18 @@ M: object empty? ( seq -- ? ) length 0 = ; ] ifte ; M: object >list ( seq -- list ) dup length 0 rot (>list) ; -M: general-list >list ( list -- list ) ; : 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ; ! Combinators -GENERIC: (seq-each) ( quot seq -- ) inline +M: object each ( quot seq -- ) + swap dup length [ + [ swap nth swap call ] 3keep + ] repeat 2drop ; -M: object (seq-each) ( quot seq -- ) - dup length [ [ swap nth swap call ] 3keep ] repeat 2drop ; +M: object tree-each call ; -M: general-list (seq-each) ( quot seq -- ) - swap each ; - -: seq-each ( seq quot -- ) swap (seq-each) ; inline - -: seq-each-with ( obj seq quot -- ) - swap [ with ] seq-each 2drop ; inline - -GENERIC: (tree-each) ( quot obj -- ) inline - -M: object (tree-each) swap call ; - -M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ; - -M: f (tree-each) swap call ; - -M: sequence (tree-each) [ (tree-each) ] seq-each-with ; - -: tree-each swap (tree-each) ; inline - -: tree-each-with ( obj vector quot -- ) - swap [ with ] tree-each 2drop ; inline +M: sequence tree-each swap [ swap tree-each ] each-with ; : change-nth ( seq i quot -- ) pick pick >r >r >r swap nth r> call r> r> swap set-nth ; @@ -74,11 +54,8 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ; : immutable ( seq quot -- seq | quot: seq -- ) swap [ thaw ] keep >r dup >r swap call r> r> freeze ; inline -: seq-map ( seq quot -- seq | quot: elt -- elt ) - swap [ swap nmap ] immutable ; inline - -: seq-map-with ( obj list quot -- list ) - swap [ with rot ] seq-map 2nip ; inline +M: object map ( seq quot -- seq | quot: elt -- elt ) + swap [ swap nmap ] immutable ; : (2nmap) ( seq1 seq2 i quot -- elt3 ) pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline @@ -89,8 +66,8 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ; [ >r 3dup r> swap (2nmap) ] keep ] repeat 3drop ; inline -: seq-2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 ) - swap [ swap 2nmap ] immutable ; inline +M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 ) + swap [ swap 2nmap ] immutable ; ! Operations : index* ( obj i seq -- n ) @@ -113,7 +90,7 @@ M: object contains? ( obj seq -- ? ) index -1 > ; : nappend ( s1 s2 -- ) #! Destructively append s2 to s1. - [ over push ] seq-each drop ; + [ over push ] each drop ; : append ( s1 s2 -- s1+s2 ) #! Return a new sequence of the same type as s1. @@ -126,7 +103,7 @@ M: object contains? ( obj seq -- ? ) index -1 > ; : concat ( seq -- seq ) #! Append together a sequence of sequences. dup empty? [ - unswons [ swap [ nappend ] seq-each-with ] immutable + unswons [ swap [ nappend ] each-with ] immutable ] unless ; M: object peek ( sequence -- element ) diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index 800a80c99d..53c7ed77ee 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -22,6 +22,27 @@ GENERIC: reverse ( seq -- seq ) GENERIC: peek ( seq -- elt ) GENERIC: contains? ( elt seq -- ? ) +G: each ( seq quot -- | quot: elt -- ) + [ over ] [ type ] ; inline + +: each-with ( obj seq quot -- | quot: obj elt -- ) + swap [ with ] each 2drop ; inline + +G: tree-each ( obj quot -- | quot: elt -- ) + [ over ] [ type ] ; inline + +: tree-each-with ( obj vector quot -- ) + swap [ with ] tree-each 2drop ; inline + +G: map ( seq quot -- seq | quot: elt -- elt ) + [ over ] [ type ] ; inline + +: map-with ( obj list quot -- list | quot: obj elt -- elt ) + swap [ with rot ] map 2nip ; inline + +G: 2map ( seq seq quot -- seq | quot: elt elt -- elt ) + [ over ] [ type ] ; inline + DEFER: append ! remove this when sort is moved from lists to sequences ! Some low-level code used by vectors and string buffers. diff --git a/library/collections/strings.factor b/library/collections/strings.factor index 8bfd7bf55c..6b2853adce 100644 --- a/library/collections/strings.factor +++ b/library/collections/strings.factor @@ -4,7 +4,8 @@ IN: strings USING: generic kernel kernel-internals lists math sequences ; ! Strings -BUILTIN: string 12 [ 1 length f ] [ 2 hashcode f ] ; +DEFER: string? +BUILTIN: string 12 string? [ 1 length f ] [ 2 hashcode f ] ; M: string = over string? [ diff --git a/library/collections/vectors.factor b/library/collections/vectors.factor index 9c356524a1..d3d139ae96 100644 --- a/library/collections/vectors.factor +++ b/library/collections/vectors.factor @@ -4,7 +4,8 @@ IN: vectors USING: errors generic kernel kernel-internals lists math math-internals sequences ; -BUILTIN: vector 11 +DEFER: vector? +BUILTIN: vector 11 vector? [ 1 length set-capacity ] [ 2 underlying set-underlying ] ; diff --git a/library/combinators.factor b/library/combinators.factor index 5456f51575..afd71e8a71 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -55,3 +55,7 @@ IN: kernel #! the quotation is evaluated. Otherwise, the condition is #! popped off the stack. dupd [ drop ] ifte ; inline + +: with ( obj quot elt -- obj quot ) + #! Utility word for each-with, map-with. + pick pick >r >r swap call r> r> ; inline diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index d569cb67a8..ca72b22191 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -17,7 +17,7 @@ GENERIC: generate-node ( vop -- ) : generate-reloc ( -- length ) relocation-table get - dup [ compile-cell ] seq-each + dup [ compile-cell ] each length cell * ; : (generate) ( word linear -- ) diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 4a5c799f5b..c58a5015c7 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-frontend -USING: compiler-backend inference kernel lists math namespaces -words strings errors prettyprint kernel-internals ; +USING: compiler-backend inference kernel kernel-internals lists +math namespaces words strings errors prettyprint sequences ; : >linear ( node -- ) #! Dataflow OPs have a linearizer word property. This diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 4f7f352e68..97d1ddd5d6 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -24,29 +24,25 @@ builtin 50 "priority" set-word-prop ! All builtin types are equivalent in ordering builtin [ 2drop t ] "class<" set-word-prop -: builtin-predicate ( type# symbol -- ) - #! We call search here because we have to know if the symbol - #! is t or f, and cannot compare type numbers or symbol - #! identity during bootstrapping. - dup "f" [ "syntax" ] search = [ - nip [ not ] "predicate" set-word-prop - ] [ - dup "t" [ "syntax" ] search = [ - nip [ ] "predicate" set-word-prop - ] [ - dup predicate-word - [ rot [ swap type eq? ] cons define-compound ] keep - unit "predicate" set-word-prop - ] ifte - ] ifte ; +: builtin-predicate ( class -- ) + dup "predicate" word-prop car swap + [ + \ type , "builtin-type" word-prop , \ eq? , + ] make-list + define-compound ; -: builtin-class ( symbol type# slotspec -- ) - >r 2dup builtins get set-nth r> - >r swap +: register-builtin ( class -- ) + dup "builtin-type" word-prop builtins get set-nth ; + +: define-builtin ( symbol type# predicate slotspec -- ) + >r >r >r dup intern-symbol - 2dup builtin-predicate - [ swap "builtin-type" set-word-prop ] keep - dup builtin define-class r> define-slots ; + dup r> "builtin-type" set-word-prop + dup builtin define-class + dup r> unit "predicate" set-word-prop + dup builtin-predicate + dup r> define-slots + register-builtin ; : builtin-type ( n -- symbol ) builtins get nth ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 7f30fbf575..58e587a647 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -17,7 +17,8 @@ math-internals ; ! based on type, or some combination of type, predicate, or ! method map. ! - metaclass: a metaclass is a symbol with a handful of word -! properties: "builtin-types" "priority" +! properties: "builtin-supertypes" "priority" "add-method" +! "class<" ! Metaclasses have priority -- this induces an order in which ! methods are added to the vtable. @@ -57,9 +58,8 @@ math-internals ; ] unless* call ; : ( generic -- vtable ) - unit num-types - [ drop dup [ car no-method ] cons ] vector-project - nip ; + [ literal, \ no-method , ] make-list + num-types swap >vector ; : ( generic -- vtable ) dup over methods [ @@ -70,8 +70,12 @@ math-internals ; : make-generic ( word -- ) #! (define-compound) is used to avoid resetting generic #! word properties. - dup over "combination" word-prop cons - (define-compound) ; + [ + dup "picker" word-prop % + dup "dispatcher" word-prop % + dup , + \ dispatch , + ] make-list (define-compound) ; : define-method ( class generic definition -- ) -rot @@ -88,30 +92,25 @@ math-internals ; ] ifte ; ! Defining generic words -: define-generic ( combination word -- ) - #! Takes a combination parameter. A combination is a - #! quotation that takes some objects and a vtable from the - #! stack, and calls the appropriate row of the vtable. - [ swap "combination" set-word-prop ] keep +: define-generic* ( picker dispatcher word -- ) + [ swap "dispatcher" set-word-prop ] keep + [ swap "picker" set-word-prop ] keep dup init-methods make-generic ; -: single-combination ( obj vtable -- ) - >r dup type r> dispatch ; inline +: define-generic ( word -- ) + >r [ dup ] [ type ] r> define-generic* ; PREDICATE: compound generic ( word -- ? ) - "combination" word-prop [ single-combination ] = ; + dup "dispatcher" word-prop [ type ] = + swap "picker" word-prop [ dup ] = and ; M: generic definer drop \ GENERIC: ; -: single-combination ( obj vtable -- ) - >r dup type r> dispatch ; inline - -: arithmetic-combination ( n n vtable -- ) - #! Note that the numbers remain on the stack, possibly after - #! being coerced to a maximal type. - >r arithmetic-type r> dispatch ; inline +: define-2generic ( word -- ) + >r [ ] [ arithmetic-type ] r> define-generic* ; PREDICATE: compound 2generic ( word -- ? ) - "combination" word-prop [ arithmetic-combination ] = ; + dup "dispatcher" word-prop [ arithmetic-type ] = + swap "picker" word-prop not and ; M: 2generic definer drop \ 2GENERIC: ; ! Maps lists of builtin type numbers to class objects. diff --git a/library/generic/slots.factor b/library/generic/slots.factor index a9dc7adc35..609aa214ec 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -11,8 +11,7 @@ sequences strings words ; #! Just like: #! GENERIC: generic #! M: class generic def ; - over [ single-combination ] swap - define-generic define-method ; + over define-generic define-method ; : define-slot-word ( class slot word quot -- ) over [ diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index a1f07b41b7..7b46257806 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -31,7 +31,8 @@ M: tuple-seq length ( tuple-seq -- len ) IN: generic -BUILTIN: tuple 18 [ 1 length f ] ; +DEFER: tuple? +BUILTIN: tuple 18 tuple? [ 1 length f ] ; ! So far, only tuples can have delegates, which also must be ! tuples (the UI uses numbers as delegates in a couple of places @@ -162,8 +163,8 @@ UNION: arrayed array tuple ; #! Generate a quotation that performs tuple class dispatch #! for methods defined on the given generic. dup default-tuple-method \ drop swons - swap tuple-methods hash>quot - [ dup class-tuple ] swap append ; + over tuple-methods hash>quot + >r "picker" word-prop [ class-tuple ] r> append3 ; : add-tuple-dispatch ( word vtable -- ) >r tuple-dispatch-quot tuple r> set-vtable ; diff --git a/library/httpd/html.factor b/library/httpd/html.factor index d4493a1cd0..64e3c83804 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -19,9 +19,7 @@ stdio streams strings unparser http ; : chars>entities ( str -- str ) #! Convert <, >, &, ' and " to HTML entities. [ - [ - dup html-entities assoc [ % ] [ , ] ?ifte - ] seq-each + [ dup html-entities assoc [ % ] [ , ] ?ifte ] each ] make-string ; : >hex-color ( triplet -- hex ) diff --git a/library/httpd/http-common.factor b/library/httpd/http-common.factor index 365f8131e4..cf00554aab 100644 --- a/library/httpd/http-common.factor +++ b/library/httpd/http-common.factor @@ -21,7 +21,7 @@ stdio streams strings unparser ; ] [ CHAR: % , >hex 2 CHAR: 0 pad % ] ifte - ] seq-each + ] each ] make-string ; : catch-hex> ( str -- n ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index f0abfd21d7..d8cfae230c 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -37,7 +37,7 @@ sequences strings vectors words hashtables prettyprint ; : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths vector-transpose [ unify-results ] seq-map ; + unify-lengths vector-transpose [ unify-results ] map ; : balanced? ( list -- ? ) #! Check if a list of [[ instack outstack ]] pairs is @@ -84,7 +84,7 @@ SYMBOL: cloned : deep-clone-seq ( seq -- seq ) #! Clone a sequence and each object it contains. - [ deep-clone ] seq-map ; + [ deep-clone ] map ; : copy-inference ( -- ) #! We avoid cloning the same object more than once in order diff --git a/library/inference/conditions.factor b/library/inference/conditions.factor index 6f38cc11bc..7bc1b4dabb 100644 --- a/library/inference/conditions.factor +++ b/library/inference/conditions.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: inference USING: errors interpreter kernel lists namespaces prettyprint -stdio ; +sequences stdio ; DEFER: recursive-state diff --git a/library/kernel.factor b/library/kernel.factor index 9c1599a7d4..1f19e17196 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -27,13 +27,14 @@ M: object clone ; #! Push t if cond is true, otherwise push f. rot [ drop ] [ nip ] ifte ; inline -: >boolean t f ? ; inline -: not ( a -- ~a ) f t ? ; inline +! defined in parse-syntax.factor +DEFER: not +DEFER: t? +: >boolean t f ? ; inline : and ( a b -- a&b ) f ? ; inline : or ( a b -- a|b ) t swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline -: implies ( a b -- a->b ) t ? ; inline : cpu ( -- arch ) 7 getenv ; : os ( -- os ) 11 getenv ; diff --git a/library/math/complex.factor b/library/math/complex.factor index cd580106cd..08edbfb05f 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -10,7 +10,8 @@ USING: errors generic kernel kernel-internals math ; IN: math -BUILTIN: complex 6 [ 0 "real" f ] [ 1 "imaginary" f ] ; +DEFER: complex? +BUILTIN: complex 6 complex? [ 0 "real" f ] [ 1 "imaginary" f ] ; UNION: number real complex ; M: real real ; diff --git a/library/math/float.factor b/library/math/float.factor index 9ed49e5203..6e3b33346f 100644 --- a/library/math/float.factor +++ b/library/math/float.factor @@ -3,7 +3,8 @@ IN: math USING: generic kernel math-internals ; -BUILTIN: float 5 ; +DEFER: float? +BUILTIN: float 5 float? ; UNION: real rational float ; M: real abs dup 0 < [ neg ] when ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 0cae4cb17a..7965a90fd6 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -3,8 +3,10 @@ IN: math USING: errors generic kernel math ; -BUILTIN: fixnum 0 ; -BUILTIN: bignum 1 ; +DEFER: fixnum? +BUILTIN: fixnum 0 fixnum? ; +DEFER: bignum? +BUILTIN: bignum 1 bignum? ; UNION: integer fixnum bignum ; : (gcd) ( b a y x -- a d ) diff --git a/library/math/math.factor b/library/math/math.factor index ada80744c8..94ff643764 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -4,28 +4,28 @@ IN: math USING: errors generic kernel math-internals ; ! Math operations -2GENERIC: number= ( x y -- ? ) +G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ; M: object number= 2drop f ; -2GENERIC: < ( x y -- ? ) -2GENERIC: <= ( x y -- ? ) -2GENERIC: > ( x y -- ? ) -2GENERIC: >= ( x y -- ? ) +G: < ( x y -- ? ) [ ] [ arithmetic-type ] ; +G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ; +G: > ( x y -- ? ) [ ] [ arithmetic-type ] ; +G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ; -2GENERIC: + ( x y -- x+y ) -2GENERIC: - ( x y -- x-y ) -2GENERIC: * ( x y -- x*y ) -2GENERIC: / ( x y -- x/y ) -2GENERIC: /i ( x y -- x/y ) -2GENERIC: /f ( x y -- x/y ) -2GENERIC: mod ( x y -- x%y ) +G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ; +G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ; +G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ; +G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ; +G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ; +G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ; +G: mod ( x y -- x%y ) [ ] [ arithmetic-type ] ; -2GENERIC: /mod ( x y -- x/y x%y ) +G: /mod ( x y -- x/y x%y ) [ ] [ arithmetic-type ] ; -2GENERIC: bitand ( x y -- z ) -2GENERIC: bitor ( x y -- z ) -2GENERIC: bitxor ( x y -- z ) -2GENERIC: shift ( x n -- y ) +G: bitand ( x y -- z ) [ ] [ arithmetic-type ] ; +G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ; +G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ; +G: shift ( x n -- y ) [ ] [ arithmetic-type ] ; GENERIC: bitnot ( n -- n ) diff --git a/library/math/matrices.factor b/library/math/matrices.factor index fdbc655dbd..b7a2a6044d 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -6,16 +6,16 @@ vectors ; : n*v ( n vec -- vec ) #! Multiply a vector by a scalar. - [ * ] seq-map-with ; + [ * ] map-with ; ! Vector operations -: v+ ( v v -- v ) [ + ] seq-2map ; -: v- ( v v -- v ) [ - ] seq-2map ; -: v* ( v v -- v ) [ * ] seq-2map ; +: v+ ( v v -- v ) [ + ] 2map ; +: v- ( v v -- v ) [ - ] 2map ; +: v* ( v v -- v ) [ * ] 2map ; ! Later, this will fixed when seq-2each works properly ! : v. ( v v -- x ) 0 swap [ * + ] seq-2each ; -: +/ ( seq -- n ) 0 swap [ + ] seq-each ; +: +/ ( seq -- n ) 0 swap [ + ] each ; : v. ( v v -- x ) v* +/ ; ! Matrices diff --git a/library/math/ratio.factor b/library/math/ratio.factor index 720dcb2ef0..609a6fd0d9 100644 --- a/library/math/ratio.factor +++ b/library/math/ratio.factor @@ -3,7 +3,8 @@ IN: math USING: generic kernel kernel-internals math math-internals ; -BUILTIN: ratio 4 [ 0 "numerator" f ] [ 1 "denominator" f ] ; +DEFER: ratio? +BUILTIN: ratio 4 ratio? [ 0 "numerator" f ] [ 1 "denominator" f ] ; UNION: rational integer ratio ; M: integer numerator ; diff --git a/library/sdl/sdl-keyboard.factor b/library/sdl/sdl-keyboard.factor index ff1dd52497..3817ec7ffc 100644 --- a/library/sdl/sdl-keyboard.factor +++ b/library/sdl/sdl-keyboard.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: sdl -USING: alien lists namespaces kernel math hashtables ; +USING: alien lists namespaces kernel math hashtables +sequences ; : SDL_EnableUNICODE ( enable -- ) "int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ; diff --git a/library/syntax/generic.factor b/library/syntax/generic.factor index 6cf6b8f267..da1c710d0e 100644 --- a/library/syntax/generic.factor +++ b/library/syntax/generic.factor @@ -6,20 +6,22 @@ IN: !syntax USING: syntax generic kernel lists namespaces parser words ; : GENERIC: - #! GENERIC: bar creates a generic word bar. Add methods to - #! the generic word using M:. - [ single-combination ] CREATE define-generic ; parsing + #! GENERIC: bar == G: bar [ dup ] [ type ] ; + CREATE define-generic ; parsing : 2GENERIC: - #! 2GENERIC: bar creates a generic word bar. Add methods to - #! the generic word using M:. 2GENERIC words dispatch on - #! arithmetic types and should not be used for non-numerical - #! types. - [ arithmetic-combination ] CREATE define-generic ; parsing + #! 2GENERIC: bar == G: bar [ ] [ arithmetic-type ] ; + #! 2GENERIC words dispatch on arithmetic types and should + #! not be used for non-numerical types. + CREATE define-2generic ; parsing + +: G: + #! G: word picker dispatcher ; + CREATE [ 2unlist rot define-generic* ] [ ] ; parsing : BUILTIN: - #! Syntax: BUILTIN: ; - CREATE scan-word [ builtin-class ] [ ] ; parsing + #! Syntax: BUILTIN: ; + CREATE scan-word scan-word [ define-builtin ] [ ] ; parsing : COMPLEMENT: ( -- ) #! Followed by a class name, then a complemented class. @@ -60,4 +62,4 @@ USING: syntax generic kernel lists namespaces parser words ; #! Followed by a tuple name, then constructor code, then ; #! Constructor code executes with the empty tuple on the #! stack. - scan-word [ define-constructor ] f ; parsing + scan-word [ define-constructor ] [ ] ; parsing diff --git a/library/syntax/parse-numbers.factor b/library/syntax/parse-numbers.factor index 4068270b9b..41ca310a76 100644 --- a/library/syntax/parse-numbers.factor +++ b/library/syntax/parse-numbers.factor @@ -20,7 +20,7 @@ M: object digit> not-a-number ; dup empty? [ not-a-number ] [ - 0 swap [ digit> pick digit+ ] seq-each nip + 0 swap [ digit> pick digit+ ] each nip ] ifte ; : base> ( str base -- num ) diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index c979edc649..fb764f5813 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -23,14 +23,15 @@ words ; ! Booleans -! The canonical t is a heap-allocated dummy object. It is always -! the first in the image. -BUILTIN: t 7 ; : t t swons ; parsing +! The canonical t is a heap-allocated dummy object. +BUILTIN: t 7 t? ; +: t t swons ; parsing ! In the runtime, the canonical f is represented as a null ! pointer with tag 3. So ! f address . ==> 3 -BUILTIN: f 9 ; : f f swons ; parsing +BUILTIN: f 9 not ; +: f f swons ; parsing ! Lists : [ f ; parsing diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 88ed00c9ba..b27a1c564c 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -181,7 +181,7 @@ M: matrix prettyprint* ( indent obj -- indent ) : [.] ( sequence -- ) #! Unparse each element on its own line. - [ . ] seq-each ; + [ . ] each ; : .s datastack reverse [.] flush ; : .r callstack reverse [.] flush ; diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 6dc0575bba..4035f67d53 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: prettyprint USING: generic hashtables kernel lists math namespaces -presentation stdio streams strings unparser words ; +sequences stdio streams strings unparser words ; ! Prettyprinting words : vocab-actions ( search -- list ) diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index f85832e8b7..4e92ff1c7a 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -87,7 +87,7 @@ M: complex unparse ( num -- str ) dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte ] unless ; -: unparse-string [ unparse-ch , ] seq-each ; +: unparse-string [ unparse-ch , ] each ; M: string unparse ( str -- str ) [ CHAR: " , unparse-string CHAR: " , ] make-string ; diff --git a/library/test/generic.factor b/library/test/generic.factor index c5fada852d..1518dc48bf 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -1,5 +1,5 @@ IN: temporary -USING: parser prettyprint sequences stdio unparser ; +USING: parser prettyprint sequences stdio strings unparser ; USE: hashtables USE: namespaces @@ -157,3 +157,15 @@ M: number union-containment drop 2 ; "GENERIC: unhappy" eval [ "M: vocabularies unhappy ;" eval ] unit-test-fails [ ] [ "GENERIC: unhappy" eval ] unit-test + +G: complex-combination [ over ] [ type ] ; +M: string complex-combination drop ; +M: object complex-combination nip ; + +[ "hi" ] [ "hi" 3 complex-combination ] unit-test +[ "hi" ] [ 3 "hi" complex-combination ] unit-test + +TUPLE: shit ; + +M: shit complex-combination cons ; +[ [[ << shit f >> 5 ]] ] [ << shit f >> 5 complex-combination ] unit-test diff --git a/library/test/strings.factor b/library/test/strings.factor index 607e80ac58..fbed1f52f5 100644 --- a/library/test/strings.factor +++ b/library/test/strings.factor @@ -80,13 +80,13 @@ unit-test [ 4 ] [ 0 "There are Four Upper Case characters" - [ LETTER? [ 1 + ] when ] seq-each + [ LETTER? [ 1 + ] when ] each ] unit-test [ "Replacing+spaces+with+plus" ] [ "Replacing spaces with plus" - [ dup CHAR: \s = [ drop CHAR: + ] when ] seq-map + [ dup CHAR: \s = [ drop CHAR: + ] when ] map ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 7134597978..1d34ca79ba 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -25,7 +25,7 @@ sequences strings test vectors ; [ { 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 empty-vector [ drop 0 100 random-int ] seq-map + 100 empty-vector [ drop 0 100 random-int ] map dup >list >vector = ] unit-test @@ -37,7 +37,7 @@ sequences strings test vectors ; [ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] - >vector [ dup * ] seq-map >list + >vector [ dup * ] map >list ] unit-test [ t ] [ { } hashcode { } hashcode = ] unit-test diff --git a/library/tools/word-tools.factor b/library/tools/word-tools.factor index bd93629d45..2408e0c57d 100644 --- a/library/tools/word-tools.factor +++ b/library/tools/word-tools.factor @@ -2,8 +2,8 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: words USING: files generic inspector lists kernel namespaces -prettyprint stdio streams strings unparser math hashtables -parser ; +prettyprint stdio streams strings sequences unparser math +hashtables parser ; : vocab-apropos ( substring vocab -- list ) #! Push a list of all words in a vocabulary whose names diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index cf4e139288..4e2c268f6e 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: generic kernel lists math namespaces prettyprint sdl -sequences stdio ; +sequences stdio sequences ; : button-down? ( n -- ? ) hand hand-buttons contains? ; diff --git a/library/ui/checkboxes.factor b/library/ui/checkboxes.factor index 9def3426c3..060c9ada42 100644 --- a/library/ui/checkboxes.factor +++ b/library/ui/checkboxes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces sdl ; +USING: generic kernel lists math namespaces sdl sequences ; : check-size 8 ; diff --git a/library/ui/frames.factor b/library/ui/frames.factor index c4703b830c..e8e065ed2a 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: gadgets generic kernel lists math namespaces sdl words ; +USING: gadgets generic kernel lists math namespaces sdl +sequences words ; ! A frame arranges left/right/top/bottom gadgets around a ! center gadget, which gets any leftover space. diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 03734775d3..dc1d50a24c 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic hashtables kernel lists math namespaces ; +USING: generic hashtables kernel lists math namespaces +sequences ; ! A gadget is a shape, a paint, a mapping of gestures to ! actions, and a reference to the gadget's parent. A gadget diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index eb3337c5b7..334c936a29 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien generic hashtables kernel lists math sdl ; +USING: alien generic hashtables kernel lists math sdl +sequences ; : action ( gadget gesture -- quot ) swap gadget-gestures hash ; diff --git a/library/ui/labels.factor b/library/ui/labels.factor index 09b8d66a8f..758c3d0142 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces sdl stdio ; +USING: generic kernel lists math namespaces sdl stdio +sequences ; ! A label gadget draws a string. TUPLE: label text ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index d22a99de18..8b9067af3c 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: errors generic hashtables kernel lists math namespaces -sdl ; +sdl sequences ; : layout ( gadget -- ) #! Set the gadget's width and height to its preferred width diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 0018d7d467..55cefbc3a5 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: generic hashtables kernel lists math namespaces sdl -stdio strings ; +stdio strings sequences ; ! Clipping diff --git a/library/ui/stacks.factor b/library/ui/stacks.factor index d3f7bcf107..6a6766ce85 100644 --- a/library/ui/stacks.factor +++ b/library/ui/stacks.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets USING: errors generic hashtables kernel lists math namespaces -sdl ; +sdl sequences ; ! A stack just lays out all its children on top of each other. TUPLE: stack ; diff --git a/library/ui/text.factor b/library/ui/text.factor index 9a43602a66..c8cccb42ae 100644 --- a/library/ui/text.factor +++ b/library/ui/text.factor @@ -52,7 +52,7 @@ global [ : filter-nulls ( str -- str ) "\0" over string-contains? [ - [ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map + [ dup CHAR: \0 = [ drop CHAR: \s ] when ] map ] when ; : size-string ( font text -- w h ) diff --git a/library/ui/world.factor b/library/ui/world.factor index ba04ffcdfe..c55fdb8a10 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -3,7 +3,7 @@ IN: gadgets USING: alien errors generic kernel lists math memory namespaces prettyprint sdl sequences stdio strings -threads ; +threads sequences ; ! The world gadget is the top level gadget that all (visible) ! gadgets are contained in. The current world is stored in the diff --git a/library/words.factor b/library/words.factor index 657818e185..09f78613e3 100644 --- a/library/words.factor +++ b/library/words.factor @@ -6,7 +6,8 @@ namespaces sequences strings vectors ; ! The basic word type. Words can be named and compared using ! identity. They hold a property map. -BUILTIN: word 17 +DEFER: word? +BUILTIN: word 17 word? [ 1 hashcode f ] [ 4 "word-def" "set-word-def" ] [ 5 "word-props" "set-word-props" ] ; @@ -130,5 +131,6 @@ M: compound definer drop \ : ; #! If the word is a generic word, clear the properties #! involved so that 'see' can work properly. over f "methods" set-word-prop - over f "combination" set-word-prop + over f "picker" set-word-prop + over f "dispatcher" set-word-prop (define-compound) ;