+ 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?
! 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 )
: 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
: 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
: (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
: 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
swap dup c-setter (define-nth) ;
: define-out ( name vocab -- )
- over [ <c-object> tuck 0 ] over c-setter append
- >r >r constructor-word r> r> cons define-compound ;
+ over [ <c-object> 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 ;
: 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 )
! 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 ;
: define-slot-word ( class slot word quot -- )
over [
- >r swap >fixnum r> cons define-typecheck
+ rot >fixnum add* define-typecheck
] [
2drop 2drop
] if ;
[ slot ] rot dup object eq? [
drop
] [
- 1array [ declare ] curry append
+ 1array [ declare ] swap add* append
] if define-slot-word ;
: define-writer ( class slot writer -- )
swap [ first classes-intersect? ] subset-with
] map-with ;
-: simplify-alist ( class assoc -- default assoc )
- dup cdr [
- 2dup cdr car first class< [
- cdr simplify-alist
+: (simplify-alist) ( class i assoc -- default assoc )
+ 2dup length 1- = [
+ nth second [ ] rot drop
+ ] [
+ 3dup >r 1+ r> nth first class< [
+ >r 1+ r> (simplify-alist)
] [
- uncons >r second nip r>
+ [ nth second ] 2keep >r 1+ r> tail rot drop
] if
- ] [
- nip car second [ ]
] 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 ;
: <vtable> ( 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> , <vtable> , \ dispatch , ] [ ] make ;
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 [
global [
4 tab-size set
64 margin set
- recursion-check off
0 position set
0 indent set
0 last-newline set
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
: with-pprint ( quot -- )
[
+ V{ } clone recursion-check set
<block> f ?push pprinter-stack set
call end-blocks do-pprint
] with-scope ; inline
-! 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.
: 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 ;
: 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 -- )
[
] annotate ;
: profile ( word -- )
- [ swap [ global [ inc ] bind call ] curry cons ] annotate ;
+ [ swap [ global [ inc ] bind ] curry swap append ] annotate ;