diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor index 024c6ea491..f4d4ac0361 100644 --- a/basis/alias/alias-docs.factor +++ b/basis/alias/alias-docs.factor @@ -6,8 +6,10 @@ HELP: ALIAS: { $values { "new-word" word } { "existing-word" word } } { $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." } { $examples - { $example "ALIAS: sequence-nth nth" - "0 { 10 20 30 } sequence-nth" + { $example "USING: alias prettyprint sequences ;" + "IN: alias.test" + "ALIAS: sequence-nth nth" + "0 { 10 20 30 } sequence-nth ." "10" } } ; diff --git a/basis/alias/authors.txt b/basis/alias/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/alias/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 0f756e0ad0..71c3fd6ff2 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -10,7 +10,7 @@ M: array c-type ; M: array heap-size unclip heap-size [ * ] reduce ; -M: array c-type-align first c-type c-type-align ; +M: array c-type-align first c-type-align ; M: array c-type-stack-align? drop f ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a9b39f80ab..f44941d88f 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -37,6 +37,7 @@ ERROR: no-c-type name ; dup string? [ (c-type) ] when ] when ; +! C type protocol GENERIC: c-type ( name -- type ) foldable : resolve-pointer-type ( name -- name ) @@ -62,6 +63,60 @@ M: string c-type ( name -- type ) ] ?if ] if ; +GENERIC: c-type-boxer ( name -- boxer ) + +M: c-type c-type-boxer boxer>> ; + +M: string c-type-boxer c-type c-type-boxer ; + +GENERIC: c-type-boxer-quot ( name -- quot ) + +M: c-type c-type-boxer-quot boxer-quot>> ; + +M: string c-type-boxer-quot c-type c-type-boxer-quot ; + +GENERIC: c-type-unboxer ( name -- boxer ) + +M: c-type c-type-unboxer unboxer>> ; + +M: string c-type-unboxer c-type c-type-unboxer ; + +GENERIC: c-type-unboxer-quot ( name -- quot ) + +M: c-type c-type-unboxer-quot unboxer-quot>> ; + +M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; + +GENERIC: c-type-reg-class ( name -- reg-class ) + +M: c-type c-type-reg-class reg-class>> ; + +M: string c-type-reg-class c-type c-type-reg-class ; + +GENERIC: c-type-getter ( name -- quot ) + +M: c-type c-type-getter getter>> ; + +M: string c-type-getter c-type c-type-getter ; + +GENERIC: c-type-setter ( name -- quot ) + +M: c-type c-type-setter setter>> ; + +M: string c-type-setter c-type c-type-setter ; + +GENERIC: c-type-align ( name -- n ) + +M: c-type c-type-align align>> ; + +M: string c-type-align c-type c-type-align ; + +GENERIC: c-type-stack-align? ( name -- ? ) + +M: c-type c-type-stack-align? stack-align?>> ; + +M: string c-type-stack-align? c-type c-type-stack-align? ; + : c-type-box ( n type -- ) dup c-type-reg-class swap c-type-boxer [ "No boxer" throw ] unless* @@ -72,10 +127,6 @@ M: string c-type ( name -- type ) swap c-type-unboxer [ "No unboxer" throw ] unless* %unbox ; -M: string c-type-align c-type c-type-align ; - -M: string c-type-stack-align? c-type c-type-stack-align? ; - GENERIC: box-parameter ( n ctype -- ) M: c-type box-parameter c-type-box ; @@ -107,25 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable M: string heap-size c-type heap-size ; -M: c-type heap-size c-type-size ; +M: c-type heap-size size>> ; GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size c-type-size ; +M: c-type stack-size size>> ; GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; : c-getter ( name -- quot ) - c-type c-type-getter [ + c-type-getter [ [ "Cannot read struct fields with type" throw ] ] unless* ; : c-setter ( name -- quot ) - c-type c-type-setter [ + c-type-setter [ [ "Cannot write struct fields with type" throw ] ] unless* ; diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 81e9ab97f7..6f83885d9f 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,13 +1,13 @@ IN: alien.structs -USING: alien.c-types strings help.markup help.syntax +USING: accessors alien.c-types strings help.markup help.syntax alien.syntax sequences io arrays slots.deprecated -kernel words slots assocs namespaces ; +kernel words slots assocs namespaces accessors ; ! Deprecated code : ($spec-reader-values) ( slot-spec class -- element ) dup ?word-name swap 2array - over slot-spec-name - rot slot-spec-class 2array 2array + over name>> + rot class>> 2array 2array [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) @@ -16,14 +16,14 @@ kernel words slots assocs namespaces ; : $spec-reader-description ( slot-spec class -- ) [ "Outputs the value stored in the " , - { $snippet } rot slot-spec-name suffix , + { $snippet } rot name>> suffix , " slot of " , { $instance } swap suffix , " instance." , ] { } make $description ; : slot-of-reader ( reader specs -- spec/f ) - [ slot-spec-reader eq? ] with find nip ; + [ reader>> eq? ] with find nip ; : $spec-reader ( reader slot-specs class -- ) >r slot-of-reader r> @@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ; : $spec-writer-description ( slot-spec class -- ) [ "Stores a new value to the " , - { $snippet } rot slot-spec-name suffix , + { $snippet } rot name>> suffix , " slot of " , { $instance } swap suffix , " instance." , ] { } make $description ; : slot-of-writer ( writer specs -- spec/f ) - [ slot-spec-writer eq? ] with find nip ; + [ writer>> eq? ] with find nip ; : $spec-writer ( writer slot-specs class -- ) >r slot-of-writer r> @@ -67,7 +67,7 @@ M: word slot-specs "slots" word-prop ; first dup "writing" word-prop [ slot-specs ] keep $spec-writer ; -M: string slot-specs c-type struct-type-fields ; +M: string slot-specs c-type fields>> ; M: array ($instance) first ($instance) " array" write ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index bfdcd31b99..8c7d9f9b29 100644 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -7,7 +7,7 @@ C-STRUCT: bar { { "int" 8 } "y" } ; [ 36 ] [ "bar" heap-size ] unit-test -[ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test +[ t ] [ \ "bar" c-type-getter memq? ] unit-test C-STRUCT: align-test { "int" "x" } diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 8671b77c9e..e6a363941d 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -6,32 +6,32 @@ slots.deprecated alien.c-types cpu.architecture ; IN: alien.structs : align-offset ( offset type -- offset ) - c-type c-type-align align ; + c-type-align align ; : struct-offsets ( specs -- size ) 0 [ [ class>> align-offset ] keep - [ set-slot-spec-offset ] 2keep + [ (>>offset) ] 2keep class>> heap-size + ] reduce ; : define-struct-slot-word ( spec word quot -- ) - rot slot-spec-offset prefix define-inline ; + rot offset>> prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ ] - [ slot-spec-reader ] + [ reader>> ] [ class>> - [ c-getter ] [ c-type c-type-boxer-quot ] bi append + [ c-getter ] [ c-type-boxer-quot ] bi append ] tri define-struct-slot-word ; : define-setter ( type spec -- ) [ set-writer-props ] keep [ ] - [ slot-spec-writer ] + [ writer>> ] [ class>> c-setter ] tri define-struct-slot-word ; @@ -44,9 +44,9 @@ IN: alien.structs TUPLE: struct-type size align fields ; -M: struct-type heap-size struct-type-size ; +M: struct-type heap-size size>> ; -M: struct-type c-type-align struct-type-align ; +M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 08da2ae14b..2388d7b8f0 100755 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors init command-line namespaces words debugger io +USING: accessors init namespaces words io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser generic sets ; +math.parser generic sets debugger command-line ; IN: bootstrap.stage2 SYMBOL: bootstrap-time diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 19427b7c79..734c19f045 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -28,4 +28,103 @@ HELP: HELP: month-names { $values { "array" array } } -{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ; +{ $description "Returns an array with the English names of all the months." } +{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; + +HELP: month-name +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; + +HELP: month-abbreviations +{ $values { "array" array } } +{ $description "Returns an array with the English abbreviated names of all the months." } +{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ; + +HELP: month-abbreviation +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; + + +HELP: day-names +{ $values { "array" array } } +{ $description "Returns an array with the English names of the days of the week." } ; + +HELP: day-name +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the day name and returns it as a string." } ; + +HELP: day-abbreviations2 +{ $values { "array" array } } +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; + +HELP: day-abbreviation2 +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ; + +HELP: day-abbreviations3 +{ $values { "array" array } } +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; + +HELP: day-abbreviation3 +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ; + +{ + day-name day-names + day-abbreviation2 day-abbreviations2 + day-abbreviation3 day-abbreviations3 +} related-words + +HELP: average-month +{ $values { "ratio" ratio } } +{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ; + +HELP: months-per-year +{ $values { "integer" integer } } +{ $description "Returns the number of months in a year." } ; + +HELP: days-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ; + +HELP: hours-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ; + +HELP: minutes-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ; + +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: 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." } +{ $warning "Not valid before year -4800 BCE." } ; + +HELP: julian-day-number>date +{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } } +{ $description "Converts from a Julian day number back to a year, month, and day." } ; +{ julian-day-number julian-day-number>date } related-words + +HELP: >date< +{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } } +{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." } +{ $examples { $example "USING: arrays calendar prettyprint ;" + "2010 8 24 >date< 3array ." + "{ 2010 8 24 }" + } +} ; + +HELP: >time< +{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } } +{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." } +{ $examples { $example "USING: arrays calendar prettyprint ;" + "now noon >time< 3array ." + "{ 12 0 0 }" + } +} ; + +{ >date< >time< } related-words diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 402542de3b..af0ced7ed2 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -57,7 +57,7 @@ PRIVATE> "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" } ; -: month-abbreviation ( n -- array ) +: month-abbreviation ( n -- string ) check-month 1- month-abbreviations nth ; : day-names ( -- array ) @@ -377,23 +377,24 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; : friday ( timestamp -- timestamp ) 5 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ; -: beginning-of-day ( timestamp -- new-timestamp ) - clone - 0 >>hour - 0 >>minute - 0 >>second ; inline +: midnight ( timestamp -- new-timestamp ) + clone 0 >>hour 0 >>minute 0 >>second ; inline + +: noon ( timestamp -- new-timestamp ) + midnight 12 >>hour ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 >>day ; + midnight 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) - beginning-of-day sunday ; + midnight sunday ; : beginning-of-year ( timestamp -- new-timestamp ) beginning-of-month 1 >>month ; : time-since-midnight ( timestamp -- duration ) - dup beginning-of-day time- ; + dup midnight time- ; + M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 36849d4ae3..bfe438fae1 100755 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ; [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f read-hms instant ; + 0 0 0 read-hms instant ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-ymd f f f instant ; + read-ymd 0 0 0 instant ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index ea54766ad4..9b5cbee04b 100755 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -3,7 +3,7 @@ ! ! Channels - based on ideas from newsqueak USING: kernel sequences sequences.lib threads continuations -random math ; +random math accessors ; IN: channels TUPLE: channel receivers senders ; @@ -17,14 +17,14 @@ GENERIC: from ( channel -- value ) > push ] curry "channel send" suspend drop ; : (to) ( value receivers -- ) delete-random resume-with yield ; : notify ( continuation channel -- channel ) - [ channel-receivers push ] keep ; + [ receivers>> push ] keep ; : (from) ( senders -- ) delete-random resume ; @@ -32,11 +32,11 @@ GENERIC: from ( channel -- value ) PRIVATE> M: channel to ( value channel -- ) - dup channel-receivers + dup receivers>> dup empty? [ drop dup wait to ] [ nip (to) ] if ; M: channel from ( channel -- value ) [ - notify channel-senders + notify senders>> dup empty? [ drop ] [ (from) ] if ] curry "channel receive" suspend ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index ca631d5dea..8bfbe330b2 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -21,6 +21,10 @@ IN: cocoa.views : NSOpenGLPFASampleBuffers 55 ; : NSOpenGLPFASamples 56 ; : NSOpenGLPFAAuxDepthStencil 57 ; +: NSOpenGLPFAColorFloat 58 ; +: NSOpenGLPFAMultisample 59 ; +: NSOpenGLPFASupersample 60 ; +: NSOpenGLPFASampleAlpha 61 ; : NSOpenGLPFARendererID 70 ; : NSOpenGLPFASingleRenderer 71 ; : NSOpenGLPFANoRecovery 72 ; @@ -34,25 +38,36 @@ IN: cocoa.views : NSOpenGLPFACompliant 83 ; : NSOpenGLPFAScreenMask 84 ; : NSOpenGLPFAPixelBuffer 90 ; +: NSOpenGLPFAAllowOfflineRenderers 96 ; : NSOpenGLPFAVirtualScreenCount 128 ; +: kCGLRendererGenericFloatID HEX: 00020400 ; + : with-software-renderer ( quot -- ) - t +software-renderer+ set - [ f +software-renderer+ set ] - [ ] cleanup ; inline + t +software-renderer+ pick with-variable ; inline +: with-multisample ( quot -- ) + t +multisample+ pick with-variable ; inline : ( -- pixelfmt ) NSOpenGLPixelFormat -> alloc [ NSOpenGLPFAWindow , NSOpenGLPFADoubleBuffer , NSOpenGLPFADepthSize , 16 , - +software-renderer+ get [ NSOpenGLPFARobust , ] when + +software-renderer+ get [ + NSOpenGLPFARendererID , kCGLRendererGenericFloatID , + ] when + +multisample+ get [ + NSOpenGLPFASupersample , + NSOpenGLPFASampleBuffers , 1 , + NSOpenGLPFASamples , 8 , + ] when 0 , ] { } make >c-int-array -> initWithAttributes: diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2947362430..d340c21663 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -42,12 +42,17 @@ SYMBOL: +failed+ [ compiled-unxref ] [ dup crossref? - [ dependencies get compiled-xref ] [ drop ] if + [ + dependencies get + generic-dependencies get + compiled-xref + ] [ drop ] if ] tri ; : (compile) ( word -- ) '[ H{ } clone dependencies set + H{ } clone generic-dependencies set , { [ compile-begins ] diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index 2452b19e11..e460f5558b 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -69,23 +69,21 @@ TUPLE: ds-loc n class ; : ( n -- loc ) f ds-loc boa ; -M: ds-loc minimal-ds-loc* ds-loc-n min ; -M: ds-loc operand-class* ds-loc-class ; -M: ds-loc set-operand-class set-ds-loc-class ; +M: ds-loc minimal-ds-loc* n>> min ; M: ds-loc live-loc? - over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ; + over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; ! A retain stack location. TUPLE: rs-loc n class ; : ( n -- loc ) f rs-loc boa ; -M: rs-loc operand-class* rs-loc-class ; -M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc live-loc? - over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ; + over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; UNION: loc ds-loc rs-loc ; +M: loc operand-class* class>> ; +M: loc set-operand-class (>>class) ; M: loc move-spec drop loc ; INSTANCE: loc value @@ -106,12 +104,12 @@ M: cached set-operand-class vreg>> set-operand-class ; M: cached operand-class* vreg>> operand-class* ; M: cached move-spec drop cached ; M: cached live-vregs* vreg>> live-vregs* ; -M: cached live-loc? cached-loc live-loc? ; +M: cached live-loc? loc>> live-loc? ; M: cached (lazy-load) >r vreg>> r> (lazy-load) ; M: cached lazy-store - 2dup cached-loc live-loc? + 2dup loc>> live-loc? [ "live-locs" get at %move ] [ 2drop ] if ; -M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ; +M: cached minimal-ds-loc* loc>> minimal-ds-loc* ; INSTANCE: cached value @@ -121,48 +119,48 @@ TUPLE: tagged vreg class ; : ( vreg -- tagged ) f tagged boa ; -M: tagged v>operand tagged-vreg v>operand ; -M: tagged set-operand-class set-tagged-class ; -M: tagged operand-class* tagged-class ; +M: tagged v>operand vreg>> v>operand ; +M: tagged set-operand-class (>>class) ; +M: tagged operand-class* class>> ; M: tagged move-spec drop f ; -M: tagged live-vregs* tagged-vreg , ; +M: tagged live-vregs* vreg>> , ; INSTANCE: tagged value ! Unboxed alien pointers TUPLE: unboxed-alien vreg ; C: unboxed-alien -M: unboxed-alien v>operand unboxed-alien-vreg v>operand ; +M: unboxed-alien v>operand vreg>> v>operand ; M: unboxed-alien operand-class* drop simple-alien ; M: unboxed-alien move-spec class ; -M: unboxed-alien live-vregs* unboxed-alien-vreg , ; +M: unboxed-alien live-vregs* vreg>> , ; INSTANCE: unboxed-alien value TUPLE: unboxed-byte-array vreg ; C: unboxed-byte-array -M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ; +M: unboxed-byte-array v>operand vreg>> v>operand ; M: unboxed-byte-array operand-class* drop c-ptr ; M: unboxed-byte-array move-spec class ; -M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ; +M: unboxed-byte-array live-vregs* vreg>> , ; INSTANCE: unboxed-byte-array value TUPLE: unboxed-f vreg ; C: unboxed-f -M: unboxed-f v>operand unboxed-f-vreg v>operand ; +M: unboxed-f v>operand vreg>> v>operand ; M: unboxed-f operand-class* drop \ f ; M: unboxed-f move-spec class ; -M: unboxed-f live-vregs* unboxed-f-vreg , ; +M: unboxed-f live-vregs* vreg>> , ; INSTANCE: unboxed-f value TUPLE: unboxed-c-ptr vreg ; C: unboxed-c-ptr -M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ; +M: unboxed-c-ptr v>operand vreg>> v>operand ; M: unboxed-c-ptr operand-class* drop c-ptr ; M: unboxed-c-ptr move-spec class ; -M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ; +M: unboxed-c-ptr live-vregs* vreg>> , ; INSTANCE: unboxed-c-ptr value diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor new file mode 100644 index 0000000000..d6868fd034 --- /dev/null +++ b/basis/compiler/tests/folding.factor @@ -0,0 +1,30 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel classes.mixin arrays ; +IN: compiler.tests + +! Calls to generic words were not folded away. + +[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: math arrays ; + IN: compiler.tests.folding + GENERIC: foldable-generic ( a -- b ) foldable + M: integer foldable-generic f ; + "> eval +] unit-test + +[ ] [ + <" + USING: math arrays ; + IN: compiler.tests.folding + : fold-test ( -- x ) 10 foldable-generic ; + "> eval +] unit-test + +[ t ] [ + "fold-test" "compiler.tests.folding" lookup execute + "fold-test" "compiler.tests.folding" lookup execute + eq? +] unit-test diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor index 4c87f73722..aa79067252 100644 --- a/basis/compiler/tests/insane.factor +++ b/basis/compiler/tests/insane.factor @@ -1,4 +1,5 @@ IN: compiler.tests -USING: words kernel stack-checker alien.strings tools.test ; +USING: words kernel stack-checker alien.strings tools.test +compiler.units ; -[ ] [ \ if redefined [ string>alien ] infer. ] unit-test +[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor new file mode 100644 index 0000000000..8a6fb8a313 --- /dev/null +++ b/basis/compiler/tests/redefine10.factor @@ -0,0 +1,29 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math classes ; + IN: compiler.tests.redefine10 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine10 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-inline" "compiler.tests.redefine10" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor new file mode 100644 index 0000000000..18b1a3a430 --- /dev/null +++ b/basis/compiler/tests/redefine11.factor @@ -0,0 +1,32 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel classes.mixin arrays ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math classes arrays ; + IN: compiler.tests.redefine11 + MIXIN: my-mixin + INSTANCE: array my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + M: my-mixin my-generic drop 0 ; + M: object my-generic drop 1 ; + : my-inline ( -- b ) { } my-generic ; + "> eval +] unit-test + +[ ] [ + [ + array "my-mixin" "compiler.tests.redefine11" lookup + remove-mixin-instance + ] with-compilation-unit +] unit-test + +[ 1 ] [ + "my-inline" "compiler.tests.redefine11" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor new file mode 100644 index 0000000000..73225c55b8 --- /dev/null +++ b/basis/compiler/tests/redefine6.factor @@ -0,0 +1,33 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel kernel.private ; + IN: compiler.tests.redefine6 + GENERIC: my-generic ( a -- b ) + MIXIN: my-mixin + M: my-mixin my-generic drop 0 ; + : my-inline ( a -- b ) { my-mixin } declare my-generic ; + "> eval +] unit-test + +[ ] [ + <" + USING: kernel ; + IN: compiler.tests.redefine6 + TUPLE: my-tuple ; + M: my-tuple my-generic drop 1 ; + INSTANCE: my-tuple my-mixin + "> eval +] unit-test + +[ 1 ] [ + "my-tuple" "compiler.tests.redefine6" lookup boa + "my-inline" "compiler.tests.redefine6" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor new file mode 100644 index 0000000000..164a2e3831 --- /dev/null +++ b/basis/compiler/tests/redefine7.factor @@ -0,0 +1,29 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math ; + IN: compiler.tests.redefine7 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine7 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-inline" "compiler.tests.redefine7" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor new file mode 100644 index 0000000000..c8b3377632 --- /dev/null +++ b/basis/compiler/tests/redefine8.factor @@ -0,0 +1,32 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math math.order sorting ; + IN: compiler.tests.redefine8 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + ! We add the bogus quotation here to hinder inlining + ! since otherwise we cannot trigger this bug. + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine8 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-generic" "compiler.tests.redefine8" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor new file mode 100644 index 0000000000..7b0f8a2e9c --- /dev/null +++ b/basis/compiler/tests/redefine9.factor @@ -0,0 +1,35 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel generic.math ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math math.order sorting ; + IN: compiler.tests.redefine9 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + ! We add the bogus quotation here to hinder inlining + ! since otherwise we cannot trigger this bug. + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine9 + TUPLE: my-tuple ; + INSTANCE: my-tuple my-mixin + "> eval +] unit-test + +[ + "my-tuple" "compiler.tests.redefine9" lookup boa + "my-generic" "compiler.tests.redefine9" lookup + execute +] [ no-math-method? ] must-fail-with diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 003bd1cc69..8056e75b3e 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup-folding ( #call -- nodes ) #! Replace a #call having a known result with a #drop of its #! inputs followed by #push nodes for the outputs. - [ word>> +inlined+ depends-on ] + [ word>> inlined-dependency depends-on ] [ [ node-output-infos ] [ out-d>> ] bi [ [ literal>> ] dip #push ] 2map @@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes ) [ in-d>> #drop ] tri prefix ; +: add-method-dependency ( #call -- ) + dup method>> word? [ + [ word>> ] [ class>> ] bi depends-on-generic + ] [ drop ] if ; + : cleanup-inlining ( #call -- nodes ) [ dup method>> - [ method>> dup word? [ +called+ depends-on ] [ drop ] if ] - [ word>> +inlined+ depends-on ] if + [ add-method-dependency ] + [ word>> inlined-dependency depends-on ] if ] [ body>> cleanup ] bi ; ! Removing overflow checks diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 2bcf91e6ab..3ea9139e5f 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -106,7 +106,7 @@ M: #push remove-dead-code* ] [ drop f ] if ; : remove-flushable-call ( #call -- node ) - [ word>> +inlined+ depends-on ] + [ word>> flushed-dependency depends-on ] [ in-d>> #drop remove-dead-code* ] bi ; diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor index 100ced5acd..4c197d7fc0 100644 --- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor @@ -103,6 +103,9 @@ DEFER: copy-value [ [ allocation copy-allocation ] dip record-allocation ] 2bi ; +: copy-values ( from to -- ) + [ copy-value ] 2each ; + : copy-slot-value ( out slot# in -- ) allocation { { [ dup not ] [ 3drop ] } diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor index 3d8d15e5ec..059ac1de02 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor @@ -42,24 +42,26 @@ IN: compiler.tree.escape-analysis.recursive ] 2bi ; M: #recursive escape-analysis* ( #recursive -- ) + [ label>> return>> in-d>> introduce-values ] [ - child>> - [ first out-d>> introduce-values ] - [ first analyze-recursive-phi ] - [ (escape-analysis) ] - tri - ] until-fixed-point ; + [ + child>> + [ first out-d>> introduce-values ] + [ first analyze-recursive-phi ] + [ (escape-analysis) ] + tri + ] until-fixed-point + ] bi ; M: #enter-recursive escape-analysis* ( #enter-recursive -- ) #! Handled by #recursive drop ; -: return-allocations ( node -- allocations ) - label>> return>> node-input-allocations ; - M: #call-recursive escape-analysis* ( #call-label -- ) - [ ] [ return-allocations ] [ node-output-allocations ] tri - [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ; + [ ] [ label>> return>> ] [ node-output-allocations ] tri + [ [ node-input-allocations ] dip check-fixed-point ] + [ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ] + 3bi ; M: #return-recursive escape-analysis* ( #return-recursive -- ) [ call-next-method ] diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index 58d721b602..d69f6cab9e 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -13,7 +13,7 @@ IN: compiler.tree.escape-analysis.simple M: #terminate escape-analysis* drop ; -M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ; +M: #renaming escape-analysis* inputs/outputs copy-values ; M: #introduce escape-analysis* out-d>> unknown-allocations ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor new file mode 100644 index 0000000000..08734ec095 --- /dev/null +++ b/basis/compiler/tree/finalization/finalization.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences +compiler.tree compiler.tree.combinators ; +IN: compiler.tree.finalization + +GENERIC: finalize* ( node -- nodes ) + +M: #copy finalize* drop f ; + +M: #shuffle finalize* + dup shuffle-effect + [ in>> ] [ out>> ] bi sequence= + [ drop f ] when ; + +M: node finalize* ; + +: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 98ec4ee3f0..12c7a60ec8 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -204,5 +204,6 @@ M: node normalize* ; H{ } clone rename-map set dup [ collect-label-info ] each-node dup count-introductions make-values - [ (normalize) ] [ nip #introduce ] 2bi prefix + [ (normalize) ] [ nip ] 2bi + dup empty? [ drop ] [ #introduce prefix ] if rename-node-values ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 5d0b8d089b..593c13b277 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -11,6 +11,7 @@ compiler.tree.strength-reduction compiler.tree.loop.detection compiler.tree.loop.inversion compiler.tree.branch-fusion +compiler.tree.finalization compiler.tree.checker ; IN: compiler.tree.optimizer @@ -25,6 +26,7 @@ IN: compiler.tree.optimizer unbox-tuples compute-def-use remove-dead-code + finalize ! strength-reduce ! USE: kernel ! compute-def-use diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e01d12ac23..09f50b21ea 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -24,18 +24,19 @@ M: quotation splicing-nodes body>> (propagate) ; ! Dispatch elimination -: eliminate-dispatch ( #call word/quot/f -- ? ) - [ +: eliminate-dispatch ( #call class/f word/f -- ? ) + dup [ + [ >>class ] dip over method>> over = [ drop ] [ 2dup splicing-nodes [ >>method ] [ >>body ] bi* ] if propagate-body t - ] [ f >>method f >>body drop f ] if* ; + ] [ 2drop f >>method f >>body f >>class drop f ] if ; -: inlining-standard-method ( #call word -- method/f ) +: inlining-standard-method ( #call word -- class/f method/f ) [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> ] dip + [ swap nth value-info class>> dup ] dip specific-method ; : inline-standard-method ( #call word -- ? ) @@ -51,15 +52,17 @@ M: quotation splicing-nodes object } [ class<= ] with find nip ; -: inlining-math-method ( #call word -- quot/f ) +: inlining-math-method ( #call word -- class/f quot/f ) swap in-d>> first2 [ value-info class>> normalize-math-class ] bi@ - 3dup math-both-known? [ math-method* ] [ 3drop f ] if ; + 3dup math-both-known? + [ math-method* ] [ 3drop f ] if + number swap ; : inline-math-method ( #call word -- ? ) dupd inlining-math-method eliminate-dispatch ; -: inlining-math-partial ( #call word -- quot/f ) +: inlining-math-partial ( #call word -- class/f quot/f ) [ "derived-from" word-prop first inlining-math-method ] [ nip 1quotation ] 2bi [ = not ] [ drop ] 2bi and ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d9fc18acb0..23323e107d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private +definitions +stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -280,6 +282,14 @@ generic-comparison-ops [ ] +constraints+ set-word-prop \ instance? [ + ! We need to force the caller word to recompile when the class + ! is redefined, since now we're making assumptions but the + ! class definition itself. dup literal>> class? - [ literal>> predicate-output-infos ] [ 2drop object-info ] if + [ + literal>> + [ inlined-dependency depends-on ] + [ predicate-output-infos ] + bi + ] [ 2drop object-info ] if ] +outputs+ set-word-prop diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 48a4b478e6..d664ae5ccf 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes classes.tuple -classes.tuple.private continuations arrays byte-arrays strings -math math.partial-dispatch math.private slots generic +classes.tuple.private continuations arrays +math math.partial-dispatch math.private slots generic definitions generic.standard generic.math +stack-checker.state compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -32,7 +33,14 @@ M: #push propagate-before [ set-value-info ] 2each ; M: #declare propagate-before - declaration>> [ swap refine-value-info ] assoc-each ; + #! We need to force the caller word to recompile when the + #! classes mentioned in the declaration are redefined, since + #! now we're making assumptions but their definitions. + declaration>> [ + [ inlined-dependency depends-on ] + [ swap refine-value-info ] + bi + ] assoc-each ; : predicate-constraints ( value class boolean-value -- constraint ) [ [ is-instance-of ] dip t--> ] @@ -74,7 +82,11 @@ M: #declare propagate-before } cond 2nip ; : propagate-predicate ( #call word -- infos ) - [ in-d>> first value-info ] [ "predicating" word-prop ] bi* + #! We need to force the caller word to recompile when the class + #! is redefined, since now we're making assumptions but the + #! class definition itself. + [ in-d>> first value-info ] + [ "predicating" word-prop dup inlined-dependency depends-on ] bi* predicate-output-infos 1array ; : default-output-value-infos ( #call word -- infos ) diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 9234aa5d86..2bb3fa0cfc 100755 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ; : #introduce ( out-d -- node ) \ #introduce new swap >>out-d ; -TUPLE: #call < node word in-d out-d body method info ; +TUPLE: #call < node word in-d out-d body method class info ; : #call ( inputs outputs word -- node ) \ #call new diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 8135572bb1..334fcb11f0 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -46,3 +46,10 @@ TUPLE: empty-tuple ; [ bleach-node ] curry [ ] compose impeach-node ; inline recursive [ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test + +TUPLE: box { i read-only } ; + +: box-test ( m -- n ) + dup box-test i>> swap box-test drop box boa ; inline recursive + +[ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 659bd2714e..67f9bbb15a 100755 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel -threads sequences calendar ; +threads sequences calendar accessors ; :: lock-test-0 ( -- ) [let | v [ V{ } clone ] @@ -174,7 +174,7 @@ threads sequences calendar ; ] ; [ lock-timeout-test ] [ - linked-error-thread thread-name "Lock timeout-er" = + thread>> name>> "Lock timeout-er" = ] must-fail-with :: read/write-test ( -- ) diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 95b6801db2..8c1392dbfb 100755 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques dlists kernel threads continuations math -concurrency.conditions ; +concurrency.conditions combinators.short-circuit accessors ; IN: concurrency.locks ! Simple critical sections @@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ; r lock-threads r> "lock" wait ] when drop - self swap set-lock-owner ; + over owner>> + [ 2dup >r threads>> r> "lock" wait ] when drop + self >>owner drop ; : release-lock ( lock -- ) - f over set-lock-owner - lock-threads notify-1 ; + f >>owner + threads>> notify-1 ; : do-lock ( lock timeout quot acquire release -- ) >r >r pick rot r> call ! use up timeout acquire @@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ; PRIVATE> : with-lock-timeout ( lock timeout quot -- ) - pick lock-reentrant? [ - pick lock-owner self eq? [ + pick reentrant?>> [ + pick owner>> self eq? [ 2nip call ] [ (with-lock) @@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop + over writer>> + [ 2dup >r readers>> r> "read lock" wait ] when drop add-reader ; : notify-writer ( lock -- ) - rw-lock-writers notify-1 ; + writers>> notify-1 ; : remove-reader ( lock -- ) - dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + [ 1- ] change-reader# drop ; : release-read-lock ( lock -- ) dup remove-reader - dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; + dup reader#>> zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock timeout -- ) - over rw-lock-writer pick rw-lock-reader# 0 > or - [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop - self swap set-rw-lock-writer ; + over writer>> pick reader#>> 0 > or + [ 2dup >r writers>> r> "write lock" wait ] when drop + self >>writer drop ; : release-write-lock ( lock -- ) - f over set-rw-lock-writer - dup rw-lock-readers deque-empty? - [ notify-writer ] [ rw-lock-readers notify-all ] if ; + f >>writer + dup readers>> deque-empty? + [ notify-writer ] [ readers>> notify-all ] if ; : reentrant-read-lock-ok? ( lock -- ? ) #! If we already have a write lock, then we can grab a read #! lock too. - rw-lock-writer self eq? ; + writer>> self eq? ; : reentrant-write-lock-ok? ( lock -- ? ) #! The only case where we have a writer and > 1 reader is #! write -> read re-entrancy, and in this case we prohibit #! a further write -> read -> write re-entrancy. - dup rw-lock-writer self eq? - swap rw-lock-reader# zero? and ; + { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ; PRIVATE> diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor index b5c022effe..0f9f97c4cc 100755 --- a/basis/concurrency/messaging/messaging-tests.factor +++ b/basis/concurrency/messaging/messaging-tests.factor @@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes concurrency.count-downs accessors ; IN: concurrency.messaging.tests -[ ] [ my-mailbox mailbox-data clear-deque ] unit-test +[ ] [ my-mailbox data>> clear-deque ] unit-test [ "received" ] [ [ diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 810e4430f1..12b5d270d4 100755 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -10,8 +10,8 @@ IN: concurrency.messaging GENERIC: send ( message thread -- ) : mailbox-of ( thread -- mailbox ) - dup thread-mailbox [ ] [ - dup rot set-thread-mailbox + dup mailbox>> [ ] [ + [ >>mailbox drop ] keep ] ?if ; M: thread send ( message thread -- ) diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor index 49c77c65ed..5868316577 100755 --- a/basis/cpu/ppc/allot/allot.factor +++ b/basis/cpu/ppc/allot/allot.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel cpu.ppc.architecture cpu.ppc.assembler kernel.private namespaces math sequences generic arrays -generator generator.registers generator.fixup system layouts +compiler.generator compiler.generator.registers +compiler.generator.fixup system layouts cpu.architecture alien ; IN: cpu.ppc.allot diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 0b570907ab..00bdb4b7c9 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types cpu.ppc.assembler cpu.architecture generic -kernel kernel.private math memory namespaces sequences words -assocs compiler.generator compiler.generator.registers -compiler.generator.fixup system layouts classes words.private -alien combinators compiler.constants math.order ; +USING: accessors alien.c-types cpu.ppc.assembler +cpu.architecture generic kernel kernel.private math memory +namespaces sequences words assocs compiler.generator +compiler.generator.registers compiler.generator.fixup system +layouts classes words.private alien combinators +compiler.constants math.order ; IN: cpu.ppc.architecture ! PowerPC register assignments @@ -65,8 +66,8 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; GENERIC: loc>operand ( loc -- reg n ) -M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ; -M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; +M: ds-loc loc>operand n>> cells neg ds-reg swap ; +M: rs-loc loc>operand n>> cells neg rs-reg swap ; M: immediate load-literal [ v>operand ] bi@ LOAD ; diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index bf990e1447..6413cf839c 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/basis/cpu/ppc/intrinsics/intrinsics.factor @@ -5,9 +5,10 @@ cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel kernel.private math math.private namespaces sequences words generic quotations byte-arrays hashtables hashtables.private compiler.generator -compiler.generator.registers generator.fixup sequences.private -sbufs vectors system layouts math.floats.private classes -slots.private combinators compiler.constants ; +compiler.generator.registers compiler.generator.fixup +sequences.private sbufs vectors system layouts +math.floats.private classes slots.private combinators +compiler.constants ; IN: cpu.ppc.intrinsics : %slot-literal-known-tag @@ -436,44 +437,44 @@ IN: cpu.ppc.intrinsics { +clobber+ { "n" } } } define-intrinsic -\ (tuple) [ - tuple "layout" get size>> 2 + cells %allot - ! Store layout - "layout" get 12 load-indirect - 12 11 cell STW - ! Store tagged ptr in reg - "tuple" get tuple %store-tagged -] H{ - { +input+ { { [ ] "layout" } } } - { +scratch+ { { f "tuple" } } } - { +output+ { "tuple" } } -} define-intrinsic - -\ (array) [ - array "n" get 2 + cells %allot - ! Store length - "n" operand 12 LI - 12 11 cell STW - ! Store tagged ptr in reg - "array" get object %store-tagged -] H{ - { +input+ { { [ ] "n" } } } - { +scratch+ { { f "array" } } } - { +output+ { "array" } } -} define-intrinsic - -\ (byte-array) [ - byte-array "n" get 2 cells + %allot - ! Store length - "n" operand 12 LI - 12 11 cell STW - ! Store tagged ptr in reg - "array" get object %store-tagged -] H{ - { +input+ { { [ ] "n" } } } - { +scratch+ { { f "array" } } } - { +output+ { "array" } } -} define-intrinsic +! \ (tuple) [ +! tuple "layout" get size>> 2 + cells %allot +! ! Store layout +! "layout" get 12 load-indirect +! 12 11 cell STW +! ! Store tagged ptr in reg +! "tuple" get tuple %store-tagged +! ] H{ +! { +input+ { { [ ] "layout" } } } +! { +scratch+ { { f "tuple" } } } +! { +output+ { "tuple" } } +! } define-intrinsic +! +! \ (array) [ +! array "n" get 2 + cells %allot +! ! Store length +! "n" operand 12 LI +! 12 11 cell STW +! ! Store tagged ptr in reg +! "array" get object %store-tagged +! ] H{ +! { +input+ { { [ ] "n" } } } +! { +scratch+ { { f "array" } } } +! { +output+ { "array" } } +! } define-intrinsic +! +! \ (byte-array) [ +! byte-array "n" get 2 cells + %allot +! ! Store length +! "n" operand 12 LI +! 12 11 cell STW +! ! Store tagged ptr in reg +! "array" get object %store-tagged +! ] H{ +! { +input+ { { [ ] "n" } } } +! { +scratch+ { { f "array" } } } +! { +output+ { "array" } } +! } define-intrinsic \ [ ratio 3 cells %allot diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index eede86085b..1577945118 100755 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,14 +1,15 @@ -USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture -namespaces alien.c-types kernel system combinators ; +USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics +cpu.architecture namespaces alien.c-types kernel system +combinators ; { { [ os macosx? ] [ - 4 "longlong" c-type set-c-type-align - 4 "ulonglong" c-type set-c-type-align - 4 "double" c-type set-c-type-align + 4 "longlong" c-type (>>align) + 4 "ulonglong" c-type (>>align) + 4 "double" c-type (>>align) ] } { [ os linux? ] [ - t "longlong" c-type set-c-type-stack-align? - t "ulonglong" c-type set-c-type-stack-align? + t "longlong" c-type (>>stack-align?) + t "ulonglong" c-type (>>stack-align?) ] } } cond diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 504707777a..6f255893db 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- ) M: x86.32 %unwind ( n -- ) %epilogue-later RET ; os windows? [ - cell "longlong" c-type set-c-type-align - cell "ulonglong" c-type set-c-type-align - 4 "double" c-type set-c-type-align + cell "longlong" c-type (>>align) + cell "ulonglong" c-type (>>align) + 4 "double" c-type (>>align) ] unless : (sse2?) ( -- ? ) "Intrinsic" throw ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0ba3b93730..c1697f1d98 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics ! The ABI for passing structs by value is pretty messed up << "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type set-c-type-reg-class >> +stack-params "__stack_value" c-type (>>reg-class) >> : struct-types&offset ( struct-type -- pairs ) - struct-type-fields [ + fields>> [ [ class>> ] [ offset>> ] bi 2array ] map ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 52ad68baf1..69bc685364 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays cpu.x86.assembler +USING: accessors alien alien.c-types arrays cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private math memory namespaces sequences words compiler.generator compiler.generator.registers compiler.generator.fixup system @@ -16,8 +16,8 @@ HOOK: stack-save-reg cpu ( -- reg ) : reg-stack ( n reg -- op ) swap cells neg [+] ; -M: ds-loc v>operand ds-loc-n ds-reg reg-stack ; -M: rs-loc v>operand rs-loc-n rs-reg reg-stack ; +M: ds-loc v>operand n>> ds-reg reg-stack ; +M: rs-loc v>operand n>> rs-reg reg-stack ; M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 51ef806ebe..06c410c0e4 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -207,7 +207,7 @@ M: no-case summary M: slice-error error. "Cannot create slice because " write - slice-error-reason print ; + reason>> print ; M: bounds-error summary drop "Sequence index out of bounds" ; @@ -232,14 +232,14 @@ M: immutable summary drop "Sequence is immutable" ; M: redefine-error error. "Re-definition of " write - redefine-error-def . ; + def>> . ; M: undefined summary drop "Calling a deferred word before it has been defined" ; M: no-compilation-unit error. "Attempting to define " write - no-compilation-unit-definition pprint + definition>> pprint " outside of a compilation unit" print ; M: no-vocab summary @@ -299,9 +299,9 @@ M: string expected>string ; M: unexpected error. "Expected " write - dup unexpected-want expected>string write + dup want>> expected>string write " but got " write - unexpected-got expected>string print ; + got>> expected>string print ; M: lexer-error error. [ lexer-dump ] [ error>> error. ] bi ; diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index 2eb2cc2762..cac7574e35 100755 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -28,10 +28,10 @@ TUPLE: document < model locs ; : update-locs ( loc document -- ) locs>> [ set-model ] with each ; -: doc-line ( n document -- string ) model-value nth ; +: doc-line ( n document -- string ) value>> nth ; : doc-lines ( from to document -- slice ) - >r 1+ r> model-value ; + >r 1+ r> value>> ; : start-on-line ( document from line# -- n1 ) >r dup first r> = [ nip second ] [ 2drop 0 ] if ; @@ -99,7 +99,7 @@ TUPLE: document < model locs ; >r >r >r "" r> r> r> set-doc-range ; : last-line# ( document -- line ) - model-value length 1- ; + value>> length 1- ; : validate-line ( line document -- line ) last-line# min 0 max ; @@ -117,7 +117,7 @@ TUPLE: document < model locs ; [ last-line# ] keep line-end ; : validate-loc ( loc document -- newloc ) - over first over model-value length >= [ + over first over value>> length >= [ nip doc-end ] [ over first 0 < [ @@ -128,7 +128,7 @@ TUPLE: document < model locs ; ] if ; : doc-string ( document -- str ) - model-value "\n" join ; + value>> "\n" join ; : set-doc-string ( string document -- ) >r string-lines V{ } like r> [ set-model ] keep diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index 61ebe744f8..28eea4701e 100755 --- a/basis/float-arrays/float-arrays.factor +++ b/basis/float-arrays/float-arrays.factor @@ -58,8 +58,7 @@ INSTANCE: float-array sequence : 4float-array ( w x y z -- array ) T{ float-array } 4sequence ; inline -: F{ ( parsed -- parsed ) - \ } [ >float-array ] parse-literal ; parsing +: F{ \ } [ >float-array ] parse-literal ; parsing M: float-array pprint-delims drop \ F{ \ } ; diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 4d942ae3a9..e5202e1306 100755 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions help help.topics help.syntax +USING: accessors definitions help help.topics help.syntax prettyprint.backend prettyprint words kernel effects ; IN: help.definitions @@ -8,30 +8,30 @@ IN: help.definitions M: link definer drop \ ARTICLE: \ ; ; -M: link where link-name article article-loc ; +M: link where name>> article loc>> ; -M: link set-where link-name article set-article-loc ; +M: link set-where name>> article (>>loc) ; -M: link forget* link-name remove-article ; +M: link forget* name>> remove-article ; M: link definition article-content ; M: link synopsis* dup definer. - dup link-name pprint* + dup name>> pprint* article-title pprint* ; M: word-link definer drop \ HELP: \ ; ; -M: word-link where link-name "help-loc" word-prop ; +M: word-link where name>> "help-loc" word-prop ; -M: word-link set-where link-name swap "help-loc" set-word-prop ; +M: word-link set-where name>> swap "help-loc" set-word-prop ; -M: word-link definition link-name "help" word-prop ; +M: word-link definition name>> "help" word-prop ; M: word-link synopsis* dup definer. - link-name dup pprint-word + name>> dup pprint-word stack-effect. ; -M: word-link forget* link-name remove-word-help ; +M: word-link forget* name>> remove-word-help ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 61d9827a48..14d3420a68 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -131,7 +131,7 @@ M: help-error error. : run-help-lint ( prefix -- alist ) [ all-vocabs-seq [ vocab-name ] map "all-vocabs" set - articles get keys "group-articles" set + group-articles "vocab-articles" set child-vocabs [ dup check-vocab ] { } map>assoc [ nip empty? not ] assoc-filter diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index e3cefb7992..d65eb8fc88 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -143,13 +143,13 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - [ dup article-name swap >link write-link ] ($span) ; + [ [ article-name ] [ >link ] bi write-link ] ($span) ; : $link ( element -- ) first ($link) ; : ($long-link) ( object -- ) - dup article-title swap >link write-link ; + [ article-title ] [ >link ] bi write-link ; : ($subsection) ( element quot -- ) [ diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 877de30748..42d5ba1781 100755 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel parser sequences words help help.topics -namespaces vocabs definitions compiler.units ; +USING: accessors arrays kernel parser sequences words help +help.topics namespaces vocabs definitions compiler.units ; IN: help.syntax : HELP: @@ -16,7 +16,6 @@ IN: help.syntax over add-article >link r> remember-definition ; parsing : ABOUT: - scan-object in get vocab - dup +inlined+ changed-definition - set-vocab-help ; parsing + dup changed-definition + scan-object >>help drop ; parsing diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index 745988c077..c52d5e347f 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -34,6 +34,6 @@ SYMBOL: foo ] unit-test [ { "testfile" 2 } ] -[ { "test" 1 } articles get at article-loc ] unit-test +[ { "test" 1 } articles get at loc>> ] unit-test [ ] [ { "test" 1 } remove-article ] unit-test diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 14a6c3f8ad..cdb32b18ee 100755 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -34,6 +34,8 @@ SYMBOL: article-xref article-xref global [ H{ } assoc-like ] change-at GENERIC: article-name ( topic -- string ) +GENERIC: article-title ( topic -- string ) +GENERIC: article-content ( topic -- content ) GENERIC: article-parent ( topic -- parent ) GENERIC: set-article-parent ( parent topic -- ) @@ -42,7 +44,9 @@ TUPLE: article title content loc ; :
( title content -- article ) f \ article boa ; -M: article article-name article-title ; +M: article article-name title>> ; +M: article article-title title>> ; +M: article article-content content>> ; ERROR: no-article name ; diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 59626a4f8a..28bce0ec42 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -55,7 +55,7 @@ IN: hints : HINTS: scan-word - [ +inlined+ changed-definition ] + [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 4ac85232b8..c774103fca 100755 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -5,8 +5,8 @@ IN: io.mmap HELP: mapped-file { $class-description "The class of memory-mapped files, opened by " { $link } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:" { $list - { { $link mapped-file-length } " - the length of the mapped file area, in bytes" } - { { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" } + { { $snippet "length" } " - the length of the mapped file area, in bytes" } + { { $snippet "address" } " - an " { $link alien } " pointing at the file's memory area" } } } ; @@ -33,8 +33,7 @@ ARTICLE: "io.mmap" "Memory-mapped files" $nl "A utility combinator which wraps the above:" { $subsection with-mapped-file } -"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:" -{ $subsection mapped-file-address } +"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl "Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ; ABOUT: "io.mmap" diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 006e0e7881..909b2dcf3b 100755 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -109,7 +109,7 @@ M: output-port stream-write1 M: output-port stream-write dup check-disposed - over length over buffer>> buffer-size > [ + over length over buffer>> size>> > [ [ buffer>> size>> ] [ [ stream-write ] curry ] bi each diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 041cff72ba..1ed83956c3 100755 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -41,7 +41,7 @@ ready ; SYMBOL: remote-address -GENERIC: handle-client* ( server -- ) +GENERIC: handle-client* ( threaded-server -- ) > call ; : thread-name ( server-name addrspec -- string ) unparse " connection from " swap 3append ; -: accept-connection ( server -- ) +: accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi [ '[ , , , handle-client ] ] [ drop threaded-server get name>> swap thread-name ] 2bi spawn drop ; -: accept-loop ( server -- ) +: accept-loop ( threaded-server -- ) [ threaded-server get semaphore>> [ [ accept-connection ] with-semaphore ] @@ -89,7 +89,7 @@ M: threaded-server handle-client* handler>> call ; if* ] [ accept-loop ] bi ; inline recursive -: started-accept-loop ( server -- ) +: started-accept-loop ( threaded-server -- ) threaded-server get [ sockets>> push ] [ ready>> raise-flag ] bi ; diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 979ac3dc21..3c77be254c 100755 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking" ABOUT: "network-streams" HELP: local -{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link } "." } +{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link } "." } { $examples { $code "\"/tmp/.X11-unix/0\" " } } ; diff --git a/basis/models/compose/compose-docs.factor b/basis/models/compose/compose-docs.factor index 8c07b2f09e..0f88499618 100755 --- a/basis/models/compose/compose-docs.factor +++ b/basis/models/compose/compose-docs.factor @@ -20,7 +20,7 @@ $nl HELP: { $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } } -{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." } +{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." } { $examples "See the example in the documentation for " { $link compose } "." } ; ARTICLE: "models-compose" "Composed models" diff --git a/basis/models/delay/delay.factor b/basis/models/delay/delay.factor index 22512942e3..a1d4ee9907 100755 --- a/basis/models/delay/delay.factor +++ b/basis/models/delay/delay.factor @@ -6,7 +6,7 @@ IN: models.delay TUPLE: delay < model model timeout alarm ; : update-delay-model ( delay -- ) - [ delay-model model-value ] keep set-model ; + [ model>> value>> ] keep set-model ; : ( model timeout -- delay ) f delay new-model @@ -15,7 +15,7 @@ TUPLE: delay < model model timeout alarm ; [ add-dependency ] keep ; : cancel-delay ( delay -- ) - delay-alarm [ cancel-alarm ] when* ; + alarm>> [ cancel-alarm ] when* ; : start-delay ( delay -- ) dup diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor index ab79d66eb6..fc90ada35a 100755 --- a/basis/models/history/history.factor +++ b/basis/models/history/history.factor @@ -14,7 +14,7 @@ TUPLE: history < model back forward ; reset-history ; : (add-history) ( history to -- ) - swap model-value dup [ swap push ] [ 2drop ] if ; + swap value>> dup [ swap push ] [ 2drop ] if ; : go-back/forward ( history to from -- ) dup empty? @@ -22,11 +22,11 @@ TUPLE: history < model back forward ; [ >r dupd (add-history) r> pop swap set-model ] if ; : go-back ( history -- ) - dup history-forward over history-back go-back/forward ; + dup [ forward>> ] [ back>> ] bi go-back/forward ; : go-forward ( history -- ) - dup history-back over history-forward go-back/forward ; + dup [ back>> ] [ forward>> ] bi go-back/forward ; : add-history ( history -- ) - dup history-forward delete-all - dup history-back (add-history) ; + dup forward>> delete-all + dup back>> (add-history) ; diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 8decf3251c..97e4557ada 100755 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -63,12 +63,7 @@ HELP: set-model { $values { "value" object } { "model" model } } { $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; -{ set-model set-model-value change-model (change-model) } related-words - -HELP: set-model-value ( value model -- ) -{ $values { "value" object } { "model" model } } -{ $description "Changes the value of a model without notifying any observers registered with " { $link add-connection } "." } -{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link set-model } ", which notifies observers." } ; +{ set-model change-model (change-model) } related-words HELP: change-model { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index cf671c5609..67bcc55a06 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces parser lexer kernel sequences words quotations math ; +USING: namespaces parser lexer kernel sequences words quotations math +accessors ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line lexer-line-text ; + lexer get dup next-line line-text>> ; : (parse-here) ( -- ) next-line-text [ @@ -22,7 +23,7 @@ IN: multiline parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get lexer-line-text [ + lexer get line-text>> [ 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 @@ -32,8 +33,8 @@ IN: multiline : parse-multiline-string ( end-text -- str ) [ - lexer get lexer-column swap (parse-multiline-string) - lexer get set-lexer-column + lexer get column>> swap (parse-multiline-string) + lexer get (>>column) ] "" make rest but-last ; : <" diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 6342deb79e..93de40d672 100755 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -17,7 +17,7 @@ TUPLE: just-parser p1 ; M: just-parser (compile) ( parser -- quot ) - just-parser-p1 compile-parser just-pattern curry ; + p1>> compile-parser just-pattern curry ; : just ( parser -- parser ) just-parser boa wrap-peg ; diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index dbfadc4ed2..a56022a039 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -38,7 +38,7 @@ HELP: pheap>alist { $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ; HELP: pheap>values -{ $values { "heap" "a persistent heap" } { "values" array } } +{ $values { "heap" "a persistent heap" } { "seq" array } } { $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ; ARTICLE: "persistent-heaps" "Persistent heaps" diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 111bcfdafc..8e5e932666 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -105,7 +105,7 @@ M: sbuf pprint* dup "SBUF\" " "\"" pprint-string ; M: pathname pprint* - dup pathname-string "P\" " "\"" pprint-string ; + dup string>> "P\" " "\"" pprint-string ; ! Sequences : nesting-limit? ( -- ? ) diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 6ad883cfcb..9bffb34ed1 100755 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -195,11 +195,11 @@ DEFER: parse-error-file : string-layout { - "USING: debugger io kernel lexer ;" + "USING: accessors debugger io kernel ;" "IN: prettyprint.tests" ": string-layout-test ( error -- )" - " \"Expected \" write dup unexpected-want expected>string write" - " \" but got \" write unexpected-got expected>string print ;" + " \"Expected \" write dup want>> expected>string write" + " \" but got \" write got>> expected>string print ;" } ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 49881f2e9f..63a44d85d4 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -172,7 +172,7 @@ M: hook-generic synopsis* [ definer. ] [ seeing-word ] [ pprint-word ] - [ "combination" word-prop hook-combination-var pprint* ] + [ "combination" word-prop var>> pprint* ] [ stack-effect. ] } cleave ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 168e118d4b..13c86ea994 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -115,10 +115,10 @@ M: object short-section? section-fits? ; : pprint-section ( section -- ) dup short-section? [ - dup section-style [ short-section ] with-style + dup style>> [ short-section ] with-style ] [ [ > [ long-section ] with-style ] [ long-section> ] tri ] if ; @@ -205,7 +205,7 @@ TUPLE: text < section string ; swap >>style swap >>string ; -M: text short-section text-string write ; +M: text short-section string>> write ; M: text long-section short-section ; @@ -291,17 +291,13 @@ SYMBOL: next : split-groups ( ? -- ) [ t , ] when ; -M: f section-start-group? drop t ; - -M: f section-end-group? drop f ; - : split-before ( section -- ) - [ section-start-group? prev get section-end-group? and ] + [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ] [ flow? prev get flow? not and ] bi or split-groups ; : split-after ( section -- ) - section-end-group? split-groups ; + [ end-group?>> ] [ f ] if* split-groups ; : group-flow ( seq -- newseq ) [ diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 6a67b132c0..4d0fd6d8aa 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state stack-checker.visitor stack-checker.errors ; IN: stack-checker.backend -! Word properties we use -SYMBOL: visited - -: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline - -: (redefined) ( word -- ) - dup visited get key? [ drop ] [ - [ reset-on-redefine reset-props ] - [ visited get conjoin ] - [ - crossref get at keys - [ word? ] filter - [ - [ reset-on-redefine [ word-prop ] with contains? ] - [ inline? ] - bi or - ] filter - [ (redefined) ] each - ] tri - ] if ; - -M: word redefined H{ } clone visited [ (redefined) ] with-variable ; - : push-d ( obj -- ) meta-d get push ; : pop-d ( -- obj ) @@ -72,7 +49,7 @@ GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> - [ dup word? [ +called+ depends-on ] [ drop ] if ] + [ dup word? [ called-dependency depends-on ] [ drop ] if ] [ push-literal ] bi ; @@ -175,6 +152,7 @@ M: object apply-object push-literal ; init-known-values stack-visitor off dependencies off + generic-dependencies off [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] [ finish-word current-effect ] bi diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 6523598cff..07ff016b2d 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -140,7 +140,7 @@ SYMBOL: enter-out ] [ undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) - [ +inlined+ depends-on ] + [ inlined-dependency depends-on ] [ { { [ dup inline-recursive-label ] [ call-recursive-inline-word ] } diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 11e7a0d7fd..c01236fba9 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback SYMBOL: +primitive+ : non-inline-word ( word -- ) - dup +called+ depends-on + dup called-dependency depends-on { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } diff --git a/basis/stack-checker/state/state-tests.factor b/basis/stack-checker/state/state-tests.factor index 91382dfb99..a4dea993c0 100644 --- a/basis/stack-checker/state/state-tests.factor +++ b/basis/stack-checker/state/state-tests.factor @@ -9,22 +9,22 @@ definitions ; SYMBOL: a SYMBOL: b -[ ] [ a +called+ depends-on ] unit-test +[ ] [ a called-dependency depends-on ] unit-test -[ H{ { a +called+ } } ] [ - [ a +called+ depends-on ] computing-dependencies +[ H{ { a called-dependency } } ] [ + [ a called-dependency depends-on ] computing-dependencies ] unit-test -[ H{ { a +called+ } { b +inlined+ } } ] [ +[ H{ { a called-dependency } { b inlined-dependency } } ] [ [ - a +called+ depends-on b +inlined+ depends-on + a called-dependency depends-on b inlined-dependency depends-on ] computing-dependencies ] unit-test -[ H{ { a +inlined+ } { b +inlined+ } } ] [ +[ H{ { a inlined-dependency } { b inlined-dependency } } ] [ [ - a +inlined+ depends-on - a +called+ depends-on - b +inlined+ depends-on + a inlined-dependency depends-on + a called-dependency depends-on + b inlined-dependency depends-on ] computing-dependencies ] unit-test diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 1f85dc39fc..3d3db980e1 100755 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces sequences kernel definitions math -effects accessors words stack-checker.errors ; +effects accessors words fry classes.algebra stack-checker.errors +compiler.units ; IN: stack-checker.state : ( -- value ) \ counter ; @@ -88,9 +89,15 @@ SYMBOL: meta-r SYMBOL: dependencies : depends-on ( word how -- ) - swap dependencies get dup [ - 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if - ] [ 3drop ] if ; + dependencies get dup + [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ; + +! Generic words that the current quotation depends on +SYMBOL: generic-dependencies + +: depends-on-generic ( generic class -- ) + generic-dependencies get dup + [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ; ! Words we've inferred the stack effect of, for rollback SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index d941f3242b..200b5d9c43 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -46,7 +46,7 @@ SYMBOL: +transform-n+ ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ +inlined+ depends-on ] [ + [ inlined-dependency depends-on ] [ [ ] [ +transform-quot+ word-prop ] [ +transform-n+ word-prop ] @@ -55,7 +55,7 @@ SYMBOL: +transform-n+ ] bi ; : apply-macro ( word -- ) - [ +inlined+ depends-on ] [ + [ inlined-dependency depends-on ] [ [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] @@ -92,13 +92,13 @@ SYMBOL: +transform-n+ \ spread [ spread>quot ] 1 define-transform \ (call-next-method) [ - [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi + [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi ] 2 define-transform ! Constructors \ boa [ dup tuple-class? [ - dup +inlined+ depends-on + dup inlined-dependency depends-on [ "boa-check" word-prop ] [ tuple-layout '[ , ] ] bi append @@ -107,7 +107,7 @@ SYMBOL: +transform-n+ \ new [ dup tuple-class? [ - dup +inlined+ depends-on + dup inlined-dependency depends-on dup all-slots rest-slice ! delegate slot [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ] [ drop f ] if diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index da308f5abf..3c4715d3e3 100755 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables" { $subsection tchange } "Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set." $nl -"Global hashtable of all threads, keyed by " { $link thread-id } ":" +"Global hashtable of all threads, keyed by " { $snippet "id" } ":" { $subsection threads } "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; @@ -63,10 +63,10 @@ ABOUT: "threads" HELP: thread { $class-description "A thread. The slots are as follows:" { $list - { { $link thread-id } " - a unique identifier assigned to each thread." } - { { $link thread-name } " - the name passed to " { $link spawn } "." } - { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } - { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } + { { $snippet "id" } " - a unique identifier assigned to each thread." } + { { $snippet "name" } " - the name passed to " { $link spawn } "." } + { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." } + { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } } } ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 5ca63a254f..9171a480cf 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -35,13 +35,13 @@ namespaces continuations layouts accessors ; [ t ] [ 1200000 small-enough? ] unit-test -[ ] [ "tetris" shake-and-bake ] unit-test - -[ t ] [ 1500000 small-enough? ] unit-test - -[ ] [ "bunny" shake-and-bake ] unit-test - -[ t ] [ 2500000 small-enough? ] unit-test +! [ ] [ "tetris" shake-and-bake ] unit-test +! +! [ t ] [ 1500000 small-enough? ] unit-test +! +! [ ] [ "bunny" shake-and-bake ] unit-test +! +! [ t ] [ 2500000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index b8c37af20a..aeec8e94f7 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.2" } - { deploy-threads? t } - { deploy-compiler? t } { deploy-math? t } - { deploy-c-types? f } - { deploy-io 2 } - { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-reflection 2 } { deploy-ui? f } - { "stop-after-last-window?" t } { deploy-word-props? f } + { deploy-threads? t } + { deploy-c-types? f } + { deploy-random? f } + { "stop-after-last-window?" t } + { deploy-name "tools.deploy.test.2" } + { deploy-io 2 } + { deploy-word-defs? f } } diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index 2c01f04bb3..1b75e46e25 100755 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -6,14 +6,14 @@ heaps.private system math math.parser math.order accessors ; IN: tools.threads : thread. ( thread -- ) - dup thread-id pprint-cell - dup thread-name over [ write-object ] with-cell - dup thread-state [ + dup id>> pprint-cell + dup name>> over [ write-object ] with-cell + dup state>> [ [ dup self eq? "running" "yield" ? ] unless* write ] with-cell [ - thread-sleep-entry [ + sleep-entry>> [ key>> millis [-] number>string write " ms" write ] when* diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 55a96c8b7d..a771a35735 100755 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ; M: vocab-tag >link ; M: vocab-tag article-title - vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; + name>> "Vocabularies tagged ``" swap "''" 3append ; -M: vocab-tag article-name vocab-tag-name ; +M: vocab-tag article-name name>> ; M: vocab-tag article-content - \ $tagged-vocabs swap vocab-tag-name 2array ; + \ $tagged-vocabs swap name>> 2array ; M: vocab-tag article-parent drop "vocab-index" ; @@ -195,12 +195,12 @@ M: vocab-tag summary article-title ; M: vocab-author >link ; M: vocab-author article-title - vocab-author-name "Vocabularies by " prepend ; + name>> "Vocabularies by " prepend ; -M: vocab-author article-name vocab-author-name ; +M: vocab-author article-name name>> ; M: vocab-author article-content - \ $authored-vocabs swap vocab-author-name 2array ; + \ $authored-vocabs swap name>> 2array ; M: vocab-author article-parent drop "vocab-index" ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 6328a3d06d..08eb3d7c32 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8 vocabs.loader vocabs sequences namespaces math.parser arrays hashtables assocs memoize summary sorting splitting combinators source-files debugger continuations compiler.errors init -checksums checksums.crc32 sets ; +checksums checksums.crc32 sets accessors ; IN: tools.vocabs : vocab-tests-file ( vocab -- path ) @@ -61,10 +61,10 @@ SYMBOL: failures : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path + dup path>> dup exists? [ utf8 file-lines crc32 checksum-lines - swap source-file-checksum = not + swap checksum>> = not ] [ 2drop f ] if @@ -175,7 +175,7 @@ M: vocab summary [ dup vocab-summary % " (" % - vocab-words assoc-size # + words>> assoc-size # " words)" % ] "" make ; diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor index 1fded308b4..f2155ec125 100755 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises models tools.walker kernel sequences concurrency.messaging locals continuations -threads namespaces namespaces.private assocs ; +threads namespaces namespaces.private assocs accessors ; IN: tools.walker.debug :: test-walker ( quot -- data ) @@ -26,6 +26,6 @@ IN: tools.walker.debug send-synchronous drop p ?promise - thread-variables walker-continuation swap at - model-value continuation-data + variables>> walker-continuation swap at + value>> data>> ] ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f9055fb6cf..9c6b87b439 100755 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -22,8 +22,8 @@ DEFER: start-walker-thread : get-walker-thread ( -- status continuation thread ) walker-thread tget [ - [ thread-variables walker-status swap at ] - [ thread-variables walker-continuation swap at ] + [ variables>> walker-status swap at ] + [ variables>> walker-continuation swap at ] [ ] tri ] [ f @@ -43,7 +43,7 @@ DEFER: start-walker-thread } cond ; : break ( -- ) - continuation callstack over set-continuation-call + continuation callstack >>call show-walker send-synchronous after-break ; @@ -163,7 +163,7 @@ SYMBOL: +stopped+ ] change-frame ; : status ( -- symbol ) - walker-status tget model-value ; + walker-status tget value>> ; : set-status ( symbol -- ) walker-status tget set-model ; @@ -248,7 +248,7 @@ SYMBOL: +stopped+ : associate-thread ( walker -- ) walker-thread tset [ f walker-thread tget send-synchronous drop ] - self set-thread-exit-handler ; + self (>>exit-handler) ; : start-walker-thread ( status continuation -- thread' ) self [ @@ -258,7 +258,7 @@ SYMBOL: +stopped+ V{ } clone walker-history tset walker-loop ] 3curry - "Walker on " self thread-name append spawn + "Walker on " self name>> append spawn [ associate-thread ] keep ; ! For convenience diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor index 4ee54cd833..e1b591dfb9 100644 --- a/basis/ui/clipboards/clipboards.factor +++ b/basis/ui/clipboards/clipboards.factor @@ -1,10 +1,22 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ui.gadgets ui.gestures namespaces ; + +USING: kernel accessors ui.gadgets ui.gestures namespaces ; + IN: ui.clipboards ! Two text transfer buffers + TUPLE: clipboard contents ; + +GENERIC: clipboard-contents ( clipboard -- string ) + +GENERIC: set-clipboard-contents ( string clipboard -- ) + +M: clipboard clipboard-contents contents>> ; + +M: clipboard set-clipboard-contents (>>contents) ; + : ( -- clipboard ) "" clipboard boa ; GENERIC: paste-clipboard ( gadget clipboard -- ) @@ -20,11 +32,10 @@ SYMBOL: clipboard SYMBOL: selection : gadget-copy ( gadget clipboard -- ) - over gadget-selection? [ - >r [ gadget-selection ] keep r> copy-clipboard - ] [ - 2drop - ] if ; + over gadget-selection? + [ >r [ gadget-selection ] keep r> copy-clipboard ] + [ 2drop ] + if ; : com-copy ( gadget -- ) clipboard get gadget-copy ; diff --git a/basis/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor index 855df9f564..ef01c6756c 100755 --- a/basis/ui/freetype/freetype-docs.factor +++ b/basis/ui/freetype/freetype-docs.factor @@ -16,12 +16,35 @@ HELP: init-freetype { $notes "Do not call this word if you are using the UI." } ; HELP: font -{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:" - { $list - { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." } - { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." } - { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." } - } + +{ $class-description + +"A font which has been loaded by FreeType. Font instances have the following slots:" + +{ + $list + { + { $snippet "ascent" } ", " + { $snippet "descent" } ", " + { $snippet "height" } " - metrics." + } + + { + { $snippet "handle" } + " - alien pointer to an " + { $snippet "FT_Face" } "." + } + + { + { $snippet "widths" } + " - sequence of character widths. Use " + { $snippet "width" } + " and " + { $snippet "width" } + " to compute string widths instead of reading this sequence directly." + } +} + } ; HELP: close-freetype diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 487da931eb..7bda548a26 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -33,7 +33,7 @@ ascent descent height handle widths ; M: font hashcode* drop font hashcode* ; -: close-font ( font -- ) font-handle FT_Done_Face ; +: close-font ( font -- ) handle>> FT_Done_Face ; : close-freetype ( -- ) global [ @@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font ) freetype drop open-fonts get [ ] cache ; : load-glyph ( font char -- glyph ) - >r font-handle dup r> 0 FT_Load_Char + >r handle>> dup r> 0 FT_Load_Char freetype-error face-glyph ; : char-width ( open-font char -- w ) - over font-widths [ + over widths>> [ dupd load-glyph glyph-hori-advance ft-ceil ] cache nip ; @@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w ) 0 -rot [ char-width + ] with each ; M: freetype-renderer string-height ( open-font string -- h ) - drop font-height ; + drop height>> ; : glyph-size ( glyph -- dim ) dup glyph-hori-advance ft-ceil @@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h ) : glyph-texture-loc ( glyph font -- loc ) over glyph-hori-bearing-x ft-floor -rot - font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; + ascent>> swap glyph-hori-bearing-y - ft-floor 2array ; : glyph-texture-size ( glyph -- dim ) [ glyph-bitmap-width next-power-of-2 ] @@ -203,7 +203,7 @@ M: freetype-renderer string-height ( open-font string -- h ) ] do-enabled ; : font-sprites ( font world -- open-font sprites ) - world-fonts [ open-font H{ } clone 2array ] cache first2 ; + fonts>> [ open-font H{ } clone 2array ] cache first2 ; M: freetype-renderer draw-string ( font string loc -- ) >r >r world get font-sprites r> r> (draw-string) ; diff --git a/basis/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor index 01426b4457..f6f5d7dd4d 100755 --- a/basis/ui/gadgets/books/books-docs.factor +++ b/basis/ui/gadgets/books/books-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ; IN: ui.gadgets.books HELP: book -{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." +{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." $nl "Books are created by calling " { $link } "." } ; diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor index 3ff9c63726..161677b56a 100755 --- a/basis/ui/gadgets/books/books.factor +++ b/basis/ui/gadgets/books/books.factor @@ -5,7 +5,7 @@ IN: ui.gadgets.books TUPLE: book < gadget ; -: hide-all ( book -- ) gadget-children [ hide-gadget ] each ; +: hide-all ( book -- ) children>> [ hide-gadget ] each ; : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ; diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 59270ead79..c4edaac144 100755 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -5,9 +5,9 @@ IN: ui.gadgets.buttons HELP: button { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation." $nl -"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "." +"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "." $nl -"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; +"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; HELP: