diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 98489f1e8a..60f02b2ab0 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -75,10 +75,9 @@ should fix in 0.82: + misc: +- make-image then compiler-tests sometimes reveals weird ghost words - 3 >n fep - code walker & exceptions - slice: if sequence or seq start is changed, abstraction violation - make 3.4 bits>double an error -- colorcoded prettyprinting for vocabularies -- signal handler should not lose stack pointers - code walker and callbacks is broken? diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 5d6de06034..e2450e434e 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: sequences -USING: errors generic kernel kernel-internals math +USING: arrays errors generic kernel kernel-internals math sequences-internals strings vectors words ; : first2 ( { x y } -- x y ) @@ -82,6 +82,11 @@ M: object like drop ; : add ( seq elt -- seq ) swap [ push ] immutable ; flushable +: add* ( seq elt -- seq ) + over >r + over thaw [ push ] keep [ swap nappend ] keep + r> like ; flushable + : diff ( seq1 seq2 -- seq2-seq1 ) [ swap member? not ] subset-with ; flushable diff --git a/library/compiler/alien/alien-callback.factor b/library/compiler/alien/alien-callback.factor index 633b7a86ec..375b982020 100644 --- a/library/compiler/alien/alien-callback.factor +++ b/library/compiler/alien/alien-callback.factor @@ -52,7 +52,7 @@ M: alien-callback-error summary ( error -- ) : generate-callback ( node -- ) [ alien-callback-xt ] keep [ dup alien-callback-parameters registers>objects - dup alien-callback-quot \ init-error-handler swons + dup alien-callback-quot \ init-error-handler add* %alien-callback unbox-return %return diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor index 213ff16c67..096826f9ba 100644 --- a/library/compiler/alien/alien-invoke.factor +++ b/library/compiler/alien/alien-invoke.factor @@ -80,8 +80,9 @@ M: alien-invoke stack-reserve* : (define-c-word) ( type lib func types stack-effect -- ) >r over create-in >r - [ alien-invoke ] cons cons cons cons r> swap define-compound - word r> "stack-effect" set-word-prop ; + [ alien-invoke ] curry curry curry curry + r> swap define-compound word r> + "stack-effect" set-word-prop ; : define-c-word ( return library function parameters -- ) [ "()" subseq? not ] subset >r pick r> parse-arglist diff --git a/library/compiler/alien/c-types.factor b/library/compiler/alien/c-types.factor index b6f88d41cb..d720775670 100644 --- a/library/compiler/alien/c-types.factor +++ b/library/compiler/alien/c-types.factor @@ -53,10 +53,10 @@ SYMBOL: c-types : define-deref ( name vocab -- ) >r dup "*" swap append r> create - swap c-getter 0 swons define-compound ; + swap c-getter 0 add* define-compound ; : (define-nth) ( word type quot -- ) - >r c-size [ rot * ] curry r> append define-compound ; + >r c-size [ rot * ] swap add* r> append define-compound ; : define-nth ( name vocab -- ) >r dup "-nth" append r> create @@ -67,8 +67,8 @@ SYMBOL: c-types swap dup c-setter (define-nth) ; : define-out ( name vocab -- ) - over [ tuck 0 ] over c-setter append - >r >r constructor-word r> r> cons define-compound ; + over [ tuck 0 ] over c-setter append swap + >r >r constructor-word r> r> add* define-compound ; : init-c-type ( name vocab -- ) over define-pointer define-nth ; diff --git a/library/compiler/alien/structs.factor b/library/compiler/alien/structs.factor index c2253d1a98..b86ca7973d 100644 --- a/library/compiler/alien/structs.factor +++ b/library/compiler/alien/structs.factor @@ -10,12 +10,12 @@ sequences strings words ; : define-getter ( offset type name -- ) #! Define a word with stack effect ( alien -- obj ) in the #! current 'in' vocabulary. - create-in >r c-getter cons r> swap define-compound ; + create-in >r c-getter swap add* r> swap define-compound ; : define-setter ( offset type name -- ) #! Define a word with stack effect ( obj alien -- ) in the #! current 'in' vocabulary. - "set-" swap append create-in >r c-setter cons r> + "set-" swap append create-in >r c-setter swap add* r> swap define-compound ; : define-field ( offset type name -- offset ) diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 125410510f..b86315eb12 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -181,9 +181,8 @@ PREDICATE: word predicate "definition" word-prop ; ! Union classes for dispatch on multiple classes. : union-predicate ( members -- list ) - [ - "predicate" word-prop \ dup swons [ drop t ] 2array - ] map [ drop f ] swap alist>quot ; + [ dup ] swap [ "predicate" word-prop append ] map-with + [ [ drop t ] 2array ] map [ drop f ] swap alist>quot ; : set-members ( class members -- ) [ bootstrap-word ] map "members" set-word-prop ; diff --git a/library/generic/slots.factor b/library/generic/slots.factor index 4ce26c9aa2..7b83fb4d7c 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -10,7 +10,7 @@ parser sequences strings words ; : define-slot-word ( class slot word quot -- ) over [ - >r swap >fixnum r> cons define-typecheck + rot >fixnum add* define-typecheck ] [ 2drop 2drop ] if ; @@ -19,7 +19,7 @@ parser sequences strings words ; [ slot ] rot dup object eq? [ drop ] [ - 1array [ declare ] curry append + 1array [ declare ] swap add* append ] if define-slot-word ; : define-writer ( class slot writer -- ) diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index 36a183faa8..0eb222ce75 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -32,34 +32,40 @@ math namespaces sequences vectors words ; swap [ first classes-intersect? ] subset-with ] map-with ; -: simplify-alist ( class assoc -- default assoc ) - dup cdr [ - 2dup cdr car first class< [ - cdr simplify-alist - ] [ - uncons >r second nip r> - ] if +: (simplify-alist) ( class i assoc -- default assoc ) + 2dup length 1- = [ + nth second [ ] rot drop ] [ - nip car second [ ] + 3dup >r 1+ r> nth first class< [ + >r 1+ r> (simplify-alist) + ] [ + [ nth second ] 2keep >r 1+ r> tail rot drop + ] if ] if ; +: simplify-alist ( class assoc -- default assoc ) + 0 swap (simplify-alist) ; + +: methods* ( dispatch# word -- assoc ) + #! Make a class->method association, together with a + #! default delegating method at the end. + empty-method object bootstrap-word swap 2array 1array + swap methods append ; + +: small-generic ( dispatch# word -- def ) + 2dup methods* object bootstrap-word swap simplify-alist + swapd class-predicates alist>quot ; + : vtable-methods ( dispatch# alist-seq -- alist-seq ) dup length [ type>class - [ swap simplify-alist ] [ car second [ ] ] if* + [ swap simplify-alist ] [ first second [ ] ] if* >r over r> class-predicates alist>quot ] 2map nip ; : ( dispatch# word n -- vtable ) #! n is vtable size; either num-types or num-tags. - >r 2dup empty-method \ object bootstrap-word swap 2array - >r methods >list r> swons r> sort-methods vtable-methods ; - -: small-generic ( dispatch# word -- def ) - 2dup empty-method object bootstrap-word swap 2array - swap methods >list cons - object bootstrap-word swap simplify-alist - swapd class-predicates alist>quot ; + >r 2dup methods* r> sort-methods vtable-methods ; : big-generic ( dispatch# word n dispatcher -- def ) [ >r pick picker % r> , , \ dispatch , ] [ ] make ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 4a29fb6482..92fefeec20 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -33,7 +33,7 @@ IN: generic define-predicate ; : forget-tuple ( class -- ) - dup forget "predicate" word-prop car [ forget ] when* ; + dup forget "predicate" word-prop first [ forget ] when* ; : check-shape ( word slots -- ) >r in get lookup dup [ diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index b2a86d8509..1c89cab400 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -24,7 +24,6 @@ SYMBOL: string-limit global [ 4 tab-size set 64 margin set - recursion-check off 0 position set 0 indent set 0 last-newline set @@ -230,9 +229,9 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ; over recursion-check get memq? [ 2drop "&" plain-text ] [ - over recursion-check [ cons ] change + over recursion-check get push call - recursion-check [ cdr ] change + recursion-check get pop* ] if ] if ; inline @@ -294,6 +293,7 @@ M: wrapper pprint* ( wrapper -- ) : with-pprint ( quot -- ) [ + V{ } clone recursion-check set f ?push pprinter-stack set call end-blocks do-pprint ] with-scope ; inline diff --git a/library/threads.factor b/library/threads.factor index a9a901c819..ce2c265129 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: threads -USING: errors hashtables io-internals kernel lists math +USING: arrays errors hashtables io-internals kernel math namespaces queues sequences vectors ; ! Co-operative multitasker. @@ -14,16 +14,16 @@ namespaces queues sequences vectors ; : sleep-queue ( -- vec ) \ sleep-queue get-global ; : sleep-queue* ( -- vec ) - sleep-queue dup [ 2car swap - ] nsort ; + sleep-queue dup [ [ first ] 2apply swap - ] nsort ; : sleep-time ( sorted-queue -- ms ) - dup empty? [ drop -1 ] [ peek car millis - 0 max ] if ; + dup empty? [ drop -1 ] [ peek first millis - 0 max ] if ; DEFER: next-thread : do-sleep ( -- continuation ) sleep-queue* dup sleep-time dup zero? - [ drop pop cdr ] [ nip io-multiplex next-thread ] if ; + [ drop pop second ] [ nip io-multiplex next-thread ] if ; : next-thread ( -- continuation ) run-queue dup queue-empty? [ drop do-sleep ] [ deque ] if ; @@ -33,7 +33,7 @@ DEFER: next-thread : yield ( -- ) [ schedule-thread stop ] callcc0 ; : sleep ( ms -- ) - millis + [ cons sleep-queue push stop ] callcc0 drop ; + millis + [ 2array sleep-queue push stop ] callcc0 drop ; : in-thread ( quot -- ) [ diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor index b8109123d5..939eafa816 100644 --- a/library/tools/annotations.factor +++ b/library/tools/annotations.factor @@ -28,4 +28,4 @@ sequences strings walker ; ] annotate ; : profile ( word -- ) - [ swap [ global [ inc ] bind call ] curry cons ] annotate ; + [ swap [ global [ inc ] bind ] curry swap append ] annotate ;