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 2c464cc74c..6f83885d9f 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,5 +1,5 @@ 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 accessors ; @@ -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 51283e2956..e6a363941d 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -6,7 +6,7 @@ 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 [ @@ -24,7 +24,7 @@ IN: alien.structs [ 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 ; @@ -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..2c23ae95c1 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math strings help.markup help.syntax -calendar.backend ; +calendar.backend math.order ; IN: calendar HELP: duration -{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ; +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ; { timestamp duration } related-words @@ -28,4 +28,168 @@ 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 + +HELP: instant +{ $values { "duration" duration } } +{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ; + +HELP: years +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: months +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: days +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: weeks +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: hours +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: minutes +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: seconds +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: milliseconds +{ $values { "x" number } { "duration" duration } } +{ $description } ; + +HELP: leap-year? +{ $values { "obj" object } { "?" "a boolean" } } +{ $description "Returns " { $link t } " if the object represents a leap year." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2008 leap-year? ." + "t" + } + { $example "USING: calendar prettyprint ;" + "2010 1 1 leap-year? ." + "f" + } +} ; + +HELP: time+ +{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } } +{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." } +{ $examples + { $example "USING: calendar math.order prettyprint ;" + "10 months 2 months time+ 1 year <=> ." + "+eq+" + } + { $example "USING: accessors calendar math.order prettyprint ;" + "2010 1 1 3 days time+ day>> ." + "4" + } +} ; + diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 402542de3b..d9284573c4 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 ) @@ -116,15 +116,15 @@ PRIVATE> : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -MEMO: instant ( -- dt ) 0 0 0 0 0 0 ; -: years ( n -- dt ) instant clone swap >>year ; -: months ( n -- dt ) instant clone swap >>month ; -: days ( n -- dt ) instant clone swap >>day ; -: weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) instant clone swap >>hour ; -: minutes ( n -- dt ) instant clone swap >>minute ; -: seconds ( n -- dt ) instant clone swap >>second ; -: milliseconds ( n -- dt ) 1000 / seconds ; +MEMO: instant ( -- duration ) 0 0 0 0 0 0 ; +: years ( x -- duration ) instant clone swap >>year ; +: months ( x -- duration ) instant clone swap >>month ; +: days ( x -- duration ) instant clone swap >>day ; +: weeks ( x -- duration ) 7 * days ; +: hours ( x -- duration ) instant clone swap >>hour ; +: minutes ( x -- duration ) instant clone swap >>minute ; +: seconds ( x -- duration ) instant clone swap >>second ; +: milliseconds ( x -- duration ) 1000 / seconds ; GENERIC: leap-year? ( obj -- ? ) @@ -218,7 +218,7 @@ M: number +second ( timestamp n -- timestamp ) PRIVATE> -GENERIC# time+ 1 ( time dt -- time ) +GENERIC# time+ 1 ( time1 time2 -- time3 ) M: timestamp time+ >r clone r> (time+) drop ; @@ -236,8 +236,8 @@ M: duration time+ 2drop ] if ; -: dt>years ( dt -- x ) - #! Uses average month/year length since dt loses calendar +: dt>years ( duration -- x ) + #! Uses average month/year length since duration loses calendar #! data 0 swap { @@ -251,12 +251,12 @@ M: duration time+ M: duration <=> [ dt>years ] compare ; -: dt>months ( dt -- x ) dt>years months-per-year * ; -: dt>days ( dt -- x ) dt>years days-per-year * ; -: dt>hours ( dt -- x ) dt>years hours-per-year * ; -: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; -: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; -: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; +: dt>months ( duration -- x ) dt>years months-per-year * ; +: dt>days ( duration -- x ) dt>years days-per-year * ; +: dt>hours ( duration -- x ) dt>years hours-per-year * ; +: dt>minutes ( duration -- x ) dt>years minutes-per-year * ; +: dt>seconds ( duration -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ; GENERIC: time- ( time1 time2 -- time ) @@ -296,7 +296,7 @@ M: timestamp time- } 2cleave ] if ; -: before ( dt -- -dt ) +: before ( duration -- -duration ) -1 time* ; M: duration time- @@ -324,8 +324,8 @@ MEMO: unix-1970 ( -- timestamp ) : now ( -- timestamp ) gmt >local-time ; -: hence ( dt -- timestamp ) now swap time+ ; -: ago ( dt -- timestamp ) now swap time- ; +: hence ( duration -- timestamp ) now swap time+ ; +: ago ( duration -- timestamp ) now swap time- ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline @@ -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/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/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/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/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index f3ecd7ae65..2281c140a4 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -12,8 +12,6 @@ IN: compiler.tree.propagation.info : null-class? ( class -- ? ) null class<= ; -SYMBOL: +interval+ - GENERIC: eql? ( obj1 obj2 -- ? ) M: object eql? eq? ; M: fixnum eql? eq? ; @@ -40,7 +38,7 @@ slots ; : class-interval ( class -- interval ) dup real class<= - [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; + [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ; : interval>literal ( class interval -- literal literal? ) #! If interval has zero length and the class is sufficiently @@ -84,7 +82,7 @@ slots ; init-value-info ; foldable : ( class -- info ) - dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or + dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or ; foldable : ( interval -- info ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 09f50b21ea..4f93769b7f 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard classes.algebra -classes.union sets quotations assocs combinators words -namespaces +math.partial-dispatch generic generic.standard generic.math +classes.algebra classes.union sets quotations assocs combinators +words namespaces compiler.tree compiler.tree.builder compiler.tree.normalization @@ -145,3 +145,13 @@ SYMBOL: history : always-inline-word? ( word -- ? ) { curry compose } memq? ; + +: do-inlining ( #call word -- ? ) + { + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup math-partial? ] [ inline-math-partial ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 23323e107d..c07c5a5cb5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -17,11 +17,11 @@ IN: compiler.tree.propagation.known-words \ fixnum most-negative-fixnum most-positive-fixnum [a,b] -+interval+ set-word-prop +"interval" set-word-prop \ array-capacity 0 max-array-capacity [a,b] -+interval+ set-word-prop +"interval" set-word-prop { + - * / } [ { number number } "input-classes" set-word-prop ] each @@ -66,17 +66,17 @@ most-negative-fixnum most-positive-fixnum [a,b] over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline { bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop + [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop ] each -\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop +\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; : fits? ( interval class -- ? ) - +interval+ word-prop interval-subset? ; + "interval" word-prop interval-subset? ; : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ @@ -120,7 +120,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ binary-op-class ] [ , binary-op-interval ] 2bi @ - ] +outputs+ set-word-prop ; + ] "outputs" set-word-prop ; \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op @@ -158,7 +158,7 @@ most-negative-fixnum most-positive-fixnum [a,b] in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ; : define-comparison-constraints ( word op -- ) - '[ , comparison-constraints ] +constraints+ set-word-prop ; + '[ , comparison-constraints ] "constraints" set-word-prop ; comparison-ops [ dup '[ , define-comparison-constraints ] each-derived-op ] each @@ -178,13 +178,13 @@ generic-comparison-ops [ comparison-ops [ dup '[ - [ , fold-comparison ] +outputs+ set-word-prop + [ , fold-comparison ] "outputs" set-word-prop ] each-derived-op ] each generic-comparison-ops [ dup specific-comparison - '[ , fold-comparison ] +outputs+ set-word-prop + '[ , fold-comparison ] "outputs" set-word-prop ] each : maybe-or-never ( ? -- info ) @@ -196,7 +196,7 @@ generic-comparison-ops [ { number= bignum= float= } [ [ info-intervals-intersect? maybe-or-never - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] each : info-classes-intersect? ( info1 info2 -- ? ) @@ -206,13 +206,13 @@ generic-comparison-ops [ over value-info literal>> fixnum? [ [ value-info literal>> is-equal-to ] dip t--> ] [ 3drop f ] if -] +constraints+ set-word-prop +] "constraints" set-word-prop \ eq? [ [ info-intervals-intersect? ] [ info-classes-intersect? ] 2bi or maybe-or-never -] +outputs+ set-word-prop +] "outputs" set-word-prop { { >fixnum fixnum } @@ -226,7 +226,7 @@ generic-comparison-ops [ interval-intersect ] 2bi - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] assoc-each { @@ -250,36 +250,36 @@ generic-comparison-ops [ } } cond [ fixnum fits? fixnum integer ? ] keep - [ 2nip ] curry +outputs+ set-word-prop + [ 2nip ] curry "outputs" set-word-prop ] each { } [ [ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if [ clear ] dip - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] each \ new [ literal>> dup tuple-class? [ drop tuple ] unless -] +outputs+ set-word-prop +] "outputs" set-word-prop ! the output of clone has the same type as the input { clone (clone) } [ [ clone f >>literal f >>literal? ] - +outputs+ set-word-prop + "outputs" set-word-prop ] each \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if -] +outputs+ set-word-prop +] "outputs" set-word-prop \ instance? [ [ value-info ] dip over literal>> class? [ [ literal>> ] dip predicate-constraints ] [ 3drop f ] if -] +constraints+ set-word-prop +] "constraints" set-word-prop \ instance? [ ! We need to force the caller word to recompile when the class @@ -292,4 +292,4 @@ generic-comparison-ops [ [ predicate-output-infos ] bi ] [ 2drop object-info ] if -] +outputs+ set-word-prop +] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 358944d1b7..9e4d99e462 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -6,9 +6,6 @@ compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes -SYMBOL: +constraints+ -SYMBOL: +outputs+ - GENERIC: propagate-before ( node -- ) GENERIC: propagate-after ( node -- ) diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index d664ae5ccf..809a85a51f 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -3,8 +3,7 @@ USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes classes.tuple classes.tuple.private continuations arrays -math math.partial-dispatch math.private slots generic definitions -generic.standard generic.math +math math.private slots generic definitions stack-checker.state compiler.tree compiler.tree.propagation.info @@ -52,7 +51,7 @@ M: #declare propagate-before with-datastack first assume ; : compute-constraints ( #call word -- ) - dup +constraints+ word-prop [ nip custom-constraints ] [ + dup "constraints" word-prop [ nip custom-constraints ] [ dup predicate? [ [ [ in-d>> first ] [ out-d>> first ] bi ] [ "predicating" word-prop ] bi* @@ -61,19 +60,22 @@ M: #declare propagate-before ] if* ; : call-outputs-quot ( #call word -- infos ) - [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi* + [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi* with-datastack ; : foldable-call? ( #call word -- ? ) "foldable" word-prop [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ; -: fold-call ( #call word -- infos ) +: (fold-call) ( #call word -- info ) [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi* '[ , , with-datastack [ ] map nip ] [ drop [ object-info ] replicate ] recover ; +: fold-call ( #call word -- ) + [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ; + : predicate-output-infos ( info class -- info ) [ class>> ] dip { { [ 2dup class<= ] [ t ] } @@ -95,30 +97,23 @@ M: #declare propagate-before : output-value-infos ( #call word -- infos ) { - { [ 2dup foldable-call? ] [ fold-call ] } { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup predicate? ] [ propagate-predicate ] } - { [ dup +outputs+ word-prop ] [ call-outputs-quot ] } + { [ dup "outputs" word-prop ] [ call-outputs-quot ] } [ default-output-value-infos ] } cond ; -: do-inlining ( #call word -- ? ) - { - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup math-partial? ] [ inline-math-partial ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond ; - M: #call propagate-before - dup word>> 2dup do-inlining [ 2drop ] [ - [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] - [ compute-constraints ] - 2bi - ] if ; + dup word>> { + { [ 2dup foldable-call? ] [ fold-call ] } + { [ 2dup do-inlining ] [ 2drop ] } + [ + [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] + [ compute-constraints ] + 2bi + ] + } cond ; M: #call annotate-node dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ; 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/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/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 65120a5d01..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 changed-definition - set-vocab-help ; parsing + scan-object >>help drop ; parsing diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index 745988c077..699b2d398a 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -1,6 +1,6 @@ -USING: definitions help help.topics help.crossref help.markup -help.syntax kernel sequences tools.test words parser namespaces -assocs source-files eval ; +USING: accessors definitions help help.topics help.crossref +help.markup help.syntax kernel sequences tools.test words parser +namespaces assocs source-files eval ; IN: help.topics.tests \ article-name must-infer @@ -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/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/macros/expander/expander.factor b/basis/macros/expander/expander.factor index f538412937..0a1703de58 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -32,8 +32,8 @@ M: wrapper expand-macros* wrapped>> literal ; stack get pop >quotation end (expand-macros) ; : expand-macro? ( word -- quot ? ) - dup [ "macro" word-prop ] [ +transform-quot+ word-prop ] bi or dup [ - swap [ stack-effect in>> length ] [ +transform-n+ word-prop ] bi or + dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [ + swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or stack get length <= ] [ 2drop f f ] if ; diff --git a/extra/math/points/points.factor b/basis/math/points/points.factor similarity index 100% rename from extra/math/points/points.factor rename to basis/math/points/points.factor 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 1cc418a1f6..67bcc55a06 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -5,7 +5,7 @@ accessors ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line text>> ; + lexer get dup next-line line-text>> ; : (parse-here) ( -- ) next-line-text [ @@ -23,7 +23,7 @@ IN: multiline parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get text>> [ + lexer get line-text>> [ 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 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/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.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 aed476b5c6..13c86ea994 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -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/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c01236fba9..5cbd5f40af 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -173,15 +173,13 @@ do-primitive alien-invoke alien-indirect alien-callback { call execute dispatch load-locals get-local drop-locals } [ t "no-compile" set-word-prop ] each -SYMBOL: +primitive+ - : non-inline-word ( word -- ) dup called-dependency depends-on { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } - { [ dup +primitive+ word-prop ] [ infer-primitive ] } - { [ dup +transform-quot+ word-prop ] [ apply-transform ] } + { [ dup "primitive" word-prop ] [ infer-primitive ] } + { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } @@ -190,7 +188,7 @@ SYMBOL: +primitive+ } cond ; : define-primitive ( word inputs outputs -- ) - [ 2drop t +primitive+ set-word-prop ] + [ 2drop t "primitive" set-word-prop ] [ drop "input-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ] 3tri ; @@ -600,8 +598,6 @@ SYMBOL: +primitive+ \ (set-os-envs) { array } { } define-primitive -\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop - \ dll-valid? { object } { object } define-primitive \ modify-code-heap { array object } { } define-primitive diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 200b5d9c43..1bdfdb6f42 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -8,9 +8,6 @@ stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors ; IN: stack-checker.transforms -SYMBOL: +transform-quot+ -SYMBOL: +transform-n+ - : give-up-transform ( word -- ) dup recursive-label [ call-recursive-word ] @@ -48,8 +45,8 @@ SYMBOL: +transform-n+ : apply-transform ( word -- ) [ inlined-dependency depends-on ] [ [ ] - [ +transform-quot+ word-prop ] - [ +transform-n+ word-prop ] + [ "transform-quot" word-prop ] + [ "transform-n" word-prop ] tri (apply-transform) ] bi ; @@ -64,8 +61,8 @@ SYMBOL: +transform-n+ ] bi ; : define-transform ( word quot n -- ) - [ drop +transform-quot+ set-word-prop ] - [ nip +transform-n+ set-word-prop ] + [ drop "transform-quot" set-word-prop ] + [ nip "transform-n" set-word-prop ] 3bi ; ! Combinators diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index eaa0342c25..5e888cd871 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -85,8 +85,11 @@ IN: tools.deploy.shaker [ strip-dictionary? [ { + "cannot-infer" "coercer" + "combination" "compiled-effect" + "compiled-generic-uses" "compiled-uses" "constraints" "declared-effect" @@ -94,38 +97,52 @@ IN: tools.deploy.shaker "default-method" "default-output-classes" "derived-from" - "identities" + "engines" "if-intrinsics" "infer" "inferred-effect" + "inline" + "inlined-block" "input-classes" "interval" "intrinsics" + "lambda" "loc" + "local-reader" + "local-reader?" + "local-writer" + "local-writer?" + "local?" + "macro" "members" - "methods" + "memo-quot" "method-class" "method-generic" - "combination" - "cannot-infer" + "methods" "no-compile" "optimizer-hooks" - "output-classes" + "outputs" "participants" "predicate" "predicate-definition" "predicating" - "tuple-dispatch-generic" - "slots" + "reader" + "reading" + "recursive" + "shuffle" "slot-names" + "slots" + "special" "specializer" "step-into" "step-into?" "superclass" - "reading" - "writing" + "transform-n" + "transform-quot" + "tuple-dispatch-generic" "type" - "engines" + "writer" + "writing" } % ] when @@ -211,6 +228,7 @@ IN: tools.deploy.shaker classes:update-map command-line:main-vocab-hook compiled-crossref + compiled-generic-crossref compiler.units:recompile-hook compiler.units:update-tuples-hook definitions:crossref diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 490c21a067..098e99719e 100755 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.1" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } { deploy-c-types? f } + { deploy-name "tools.deploy.test.1" } { deploy-io 2 } - { deploy-reflection 1 } - { deploy-ui? f } + { deploy-random? f } + { deploy-math? t } + { deploy-compiler? t } + { deploy-reflection 2 } { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-ui? f } { deploy-word-props? f } + { deploy-word-defs? f } } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index aeec8e94f7..c6f46eede6 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-math? t } - { deploy-compiler? t } - { deploy-reflection 2 } + { deploy-io 2 } { deploy-ui? f } - { 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-compiler? t } + { deploy-word-props? f } + { deploy-reflection 2 } { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index dde8291658..5f45b87e0d 100755 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.3" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } - { deploy-c-types? f } { deploy-io 3 } - { deploy-reflection 1 } { deploy-ui? f } - { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.3" } + { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 65ead56e2b..ea899e64c0 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 2 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.4" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.4" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index bb4580b7ae..797116e09b 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 3 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.5" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.5" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } 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/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor index 2b252404d6..f2155ec125 100755 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -27,5 +27,5 @@ IN: tools.walker.debug p ?promise variables>> walker-continuation swap at - model-value data>> + value>> data>> ] ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index cb5283e797..9c6b87b439 100755 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -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 ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 7bda548a26..d2dfe56ed4 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -184,7 +184,7 @@ M: freetype-renderer string-height ( open-font string -- h ) : draw-char ( open-font sprites char loc -- ) GL_MODELVIEW [ 0 0 glTranslated - char-sprite sprite-dlist glCallList + char-sprite dlist>> glCallList ] do-matrix ; : char-widths ( open-font string -- widths ) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 06a8b4886a..8142297318 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -55,9 +55,9 @@ M: editor ungraft* dup caret>> deactivate-editor-model dup mark>> deactivate-editor-model ; -: editor-caret* ( editor -- loc ) caret>> model-value ; +: editor-caret* ( editor -- loc ) caret>> value>> ; -: editor-mark* ( editor -- loc ) mark>> model-value ; +: editor-mark* ( editor -- loc ) mark>> value>> ; : set-caret ( loc editor -- ) [ model>> validate-loc ] keep @@ -501,7 +501,7 @@ TUPLE: field < wrapper field-model editor ; swap >>field-model ; M: field graft* - [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ] + [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ] [ dup editor>> model>> add-connection ] bi ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bcf908571c..15850ae357 100755 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -50,7 +50,7 @@ M: gadget model-changed 2drop ; dup model>> dup [ 2dup remove-connection ] when 2drop ; : control-value ( control -- value ) - model>> model-value ; + model>> value>> ; : set-control-value ( value control -- ) model>> set-model ; diff --git a/basis/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor index 1ad5063013..1c12142593 100644 --- a/basis/ui/gadgets/handler/handler.factor +++ b/basis/ui/gadgets/handler/handler.factor @@ -8,4 +8,4 @@ TUPLE: handler < wrapper table ; : ( child -- handler ) handler new-wrapper ; M: handler handle-gesture ( gesture gadget -- ? ) - over table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file + tuck table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 77b88959c9..3291a1c42a 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -41,7 +41,7 @@ M: incremental pref-dim* swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup forget-pref-dim dup pref-dim swap set-rect-dim ; + dup forget-pref-dim dup pref-dim >>dim drop ; : add-incremental ( gadget incremental -- ) not-in-layout diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index c7bfc99024..a4bb353d1b 100644 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -138,7 +138,7 @@ M: polygon draw-interior : ( color points -- gadget ) dup max-dim - >r r> over set-rect-dim + >r r> >>dim [ (>>interior) ] keep ; ! Font rendering diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 8f180714c8..33523701aa 100755 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -39,17 +39,17 @@ M: browser-gadget ungraft* : showing-definition? ( defspec assoc -- ? ) [ key? ] 2keep - [ >r dup word-link? [ link-name ] when r> key? ] 2keep + [ >r dup word-link? [ name>> ] when r> key? ] 2keep >r dup vocab-link? [ vocab ] when r> key? or or ; M: browser-gadget definitions-changed ( assoc browser -- ) history>> - dup model-value rot showing-definition? + dup value>> rot showing-definition? [ notify-connections ] [ drop ] if ; : help-action ( browser-gadget -- link ) - history>> model-value >link ; + history>> value>> >link ; : com-follow ( link -- ) browser-gadget call-tool ; diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 203406c6cb..5a3ad01d2e 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -11,7 +11,7 @@ USING: accessors arrays ui ui.commands ui.gestures ui.gadgets IN: ui.tools.debugger : ( restarts restart-hook -- gadget ) - [ restart-name ] rot ; + [ name>> ] rot ; TUPLE: debugger < track restarts ; diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index 407484ba97..89f238b574 100755 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -118,7 +118,7 @@ M: live-search pref-dim* drop { 400 200 } ; : ( string files -- gadget ) source-file-candidates - f [ pathname-string ] ; + f [ string>> ] ; : all-source-files ( -- seq ) source-files get keys natural-sort ; @@ -146,7 +146,7 @@ M: live-search pref-dim* drop { 400 200 } ; : ( string seq -- gadget ) history-candidates - f [ input-string ] ; + f [ string>> ] ; : listener-history ( listener -- seq ) listener-gadget-input interactor-history ; diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 05cb043e49..92c5e09a88 100755 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -9,15 +9,15 @@ USING: accessors continuations kernel models namespaces IN: ui.tools.traceback : ( model -- gadget ) - [ [ continuation-call callstack. ] when* ] + [ [ call>> callstack. ] when* ] t "Call stack" ; : ( model -- gadget ) - [ [ continuation-data stack. ] when* ] + [ [ data>> stack. ] when* ] t "Data stack" ; : ( model -- gadget ) - [ [ continuation-retain stack. ] when* ] + [ [ retain>> stack. ] when* ] t "Retain stack" ; TUPLE: traceback-gadget < track ; @@ -39,7 +39,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; dup f track-add ; : ( model -- gadget ) - [ [ continuation-name namestack. ] when* ] + [ [ name>> namestack. ] when* ] ; : ( model -- gadget ) diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index c667e6918d..767be92687 100755 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -41,7 +41,7 @@ M: walker-gadget focusable-child* : walker-state-string ( status thread -- string ) [ "Thread: " % - dup thread-name % + dup name>> % " (" % swap { { +stopped+ "Stopped" } @@ -92,7 +92,7 @@ walker-gadget "toolbar" f { [ swap walker-for-thread? ] curry find-window ; : walker-window ( status continuation thread -- ) - [ ] [ thread-name ] bi open-status-window ; + [ ] [ name>> ] bi open-status-window ; [ dup find-walker-window dup diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 56567fab85..7415bd0eb2 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -210,7 +210,7 @@ M: enum at* M: enum set-at seq>> set-nth ; -M: enum delete-at enum-seq delete-nth ; +M: enum delete-at seq>> delete-nth ; M: enum >alist ( enum -- alist ) seq>> [ length ] keep zip ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a7770e2eb2..56e995899b 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -78,8 +78,8 @@ TUPLE: mixin-instance loc class mixin ; M: mixin-instance equal? { { [ over mixin-instance? not ] [ f ] } - { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } - { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } + { [ 2dup [ class>> ] bi@ = not ] [ f ] } + { [ 2dup [ mixin>> ] bi@ = not ] [ f ] } [ t ] } cond 2nip ; @@ -91,15 +91,14 @@ M: mixin-instance hashcode* swap >>mixin swap >>class ; -M: mixin-instance where mixin-instance-loc ; +M: mixin-instance where loc>> ; -M: mixin-instance set-where set-mixin-instance-loc ; +M: mixin-instance set-where (>>loc) ; M: mixin-instance definer drop \ INSTANCE: f ; M: mixin-instance definition drop f ; M: mixin-instance forget* - dup mixin-instance-class - swap mixin-instance-mixin dup mixin-class? - [ remove-mixin-instance ] [ 2drop ] if ; + [ class>> ] [ mixin>> ] bi + dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 78799287f5..fa29a5a519 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel continuations assocs namespaces sequences words vocabs definitions hashtables init sets -math.order classes classes.algebra ; +math math.order classes classes.algebra ; IN: compiler.units SYMBOL: old-definitions @@ -73,11 +73,20 @@ GENERIC: definitions-changed ( assoc obj -- ) SYMBOL: outdated-tuples SYMBOL: update-tuples-hook +: dependency>= ( how1 how2 -- ? ) + [ + { + called-dependency + flushed-dependency + inlined-dependency + } index + ] bi@ >= ; + : strongest-dependency ( how1 how2 -- how ) - [ called-dependency or ] bi@ max ; + [ called-dependency or ] bi@ [ dependency>= ] most ; : weakest-dependency ( how1 how2 -- how ) - [ inlined-dependency or ] bi@ min ; + [ inlined-dependency or ] bi@ [ dependency>= not ] most ; : compiled-usage ( word -- assoc ) compiled-crossref get at ; @@ -89,7 +98,7 @@ SYMBOL: update-tuples-hook #! don't have to recompile words that folded this away. [ compiled-usage ] [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi - [ after=? nip ] curry assoc-filter ; + [ dependency>= nip ] curry assoc-filter ; : compiled-usages ( assoc -- assocs ) [ drop word? ] assoc-filter diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 1d3c061a42..bfa3848186 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -178,7 +178,7 @@ M: condition compute-restarts [ error>> compute-restarts ] [ [ restarts>> ] - [ condition-continuation [ ] curry ] bi + [ continuation>> [ ] curry ] bi { } assoc>map ] bi append ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index d9e9732488..2b8646fda4 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -5,23 +5,9 @@ USING: kernel sequences namespaces assocs graphs math math.order ; ERROR: no-compilation-unit definition ; -SINGLETON: inlined-dependency -SINGLETON: flushed-dependency -SINGLETON: called-dependency - -UNION: dependency -inlined-dependency -flushed-dependency -called-dependency ; - -M: dependency <=> - [ - { - called-dependency - flushed-dependency - inlined-dependency - } index - ] bi@ <=> ; +SYMBOL: inlined-dependency +SYMBOL: flushed-dependency +SYMBOL: called-dependency SYMBOL: changed-definitions diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 15ee233dbc..36cec298bd 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -130,9 +130,9 @@ M: encoder stream-write1 M: encoder stream-write >encoder< decoder-write ; -M: encoder dispose encoder-stream dispose ; +M: encoder dispose stream>> dispose ; -M: encoder stream-flush encoder-stream stream-flush ; +M: encoder stream-flush stream>> stream-flush ; INSTANCE: encoder plain-writer PRIVATE> diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 63e193c89f..74cbe3b532 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -1,5 +1,5 @@ USING: sorting sequences kernel math math.order random -tools.test vectors sets ; +tools.test vectors sets vocabs ; IN: sorting.tests [ { } ] [ { } natural-sort ] unit-test @@ -24,3 +24,5 @@ unit-test [ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ] [ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test + +[ ] [ all-words natural-sort drop ] unit-test diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index aa2cd563a5..767c2a1f79 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -56,7 +56,7 @@ ERROR: invalid-source-file-path path ; ] [ 2drop ] if ] assoc-each ; -M: pathname where pathname-string 1 2array ; +M: pathname where string>> 1 2array ; : forget-source ( path -- ) [ @@ -69,7 +69,7 @@ M: pathname where pathname-string 1 2array ; bi ; M: pathname forget* - pathname-string forget-source ; + string>> forget-source ; : rollback-source-file ( file -- ) [ diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index ce84943328..e156832923 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays byte-vectors +USING: accessors alien arrays byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words quotations io assocs splitting classes.tuple @@ -193,7 +193,7 @@ IN: bootstrap.syntax "))" parse-effect parsed ] define-syntax - "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax + "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax "<<" [ [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index fedd6de3b7..1bdbe3ce14 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -16,44 +16,78 @@ source-loaded? docs-loaded? ; swap >>name H{ } clone >>words ; +GENERIC: vocab-name ( vocab-spec -- name ) + GENERIC: vocab ( vocab-spec -- vocab ) M: vocab vocab ; M: object vocab ( name -- vocab ) vocab-name dictionary get at ; +M: vocab vocab-name name>> ; + M: string vocab-name ; +GENERIC: vocab-words ( vocab-spec -- words ) + +M: vocab vocab-words words>> ; + M: object vocab-words vocab vocab-words ; +M: f vocab-words ; + +GENERIC: vocab-help ( vocab-spec -- help ) + +M: vocab vocab-help help>> ; + M: object vocab-help vocab vocab-help ; +M: f vocab-help ; + +GENERIC: vocab-main ( vocab-spec -- main ) + +M: vocab vocab-main main>> ; + M: object vocab-main vocab vocab-main ; +M: f vocab-main ; + +GENERIC: vocab-source-loaded? ( vocab-spec -- ? ) + +M: vocab vocab-source-loaded? source-loaded?>> ; + M: object vocab-source-loaded? vocab vocab-source-loaded? ; +M: f vocab-source-loaded? ; + +GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- ) + +M: vocab set-vocab-source-loaded? (>>source-loaded?) ; + M: object set-vocab-source-loaded? vocab set-vocab-source-loaded? ; +M: f set-vocab-source-loaded? 2drop ; + +GENERIC: vocab-docs-loaded? ( vocab-spec -- ? ) + +M: vocab vocab-docs-loaded? docs-loaded?>> ; + M: object vocab-docs-loaded? vocab vocab-docs-loaded? ; +M: f vocab-docs-loaded? ; + +GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- ) + +M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ; + M: object set-vocab-docs-loaded? vocab set-vocab-docs-loaded? ; -M: f vocab-words ; - -M: f vocab-source-loaded? ; - -M: f set-vocab-source-loaded? 2drop ; - -M: f vocab-docs-loaded? ; - M: f set-vocab-docs-loaded? 2drop ; -M: f vocab-help ; - : create-vocab ( name -- vocab ) dictionary get [ ] cache ; @@ -90,10 +124,9 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link boa ; -M: vocab-link hashcode* - vocab-link-name hashcode* ; +M: vocab-link hashcode* name>> hashcode* ; -M: vocab-link vocab-name vocab-link-name ; +M: vocab-link vocab-name name>> ; UNION: vocab-spec vocab vocab-link ; diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 3509deb2fb..3c4aea028b 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -54,7 +54,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; : (set-tag) ( -- ) elements get id>> 31 bitand - dup elements get set-element-tag + dup elements get (>>tag) 31 < [ [ "unsupported tag encoding: #{" % get-id # "}" % @@ -63,22 +63,22 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; : set-tagclass ( -- ) get-id -6 shift tag-classes nth - elements get set-element-tagclass ; + elements get (>>tagclass) ; : set-encoding ( -- ) get-id HEX: 20 bitand zero? "primitive" "constructed" ? - elements get set-element-encoding ; + elements get (>>encoding) ; : set-content-length ( -- ) read1 dup 127 <= [ 127 bitand read be> - ] unless elements get set-element-contentlength ; + ] unless elements get (>>contentlength) ; : set-newobj ( -- ) elements get contentlength>> read - elements get set-element-newobj ; + elements get (>>newobj) ; : set-objtype ( syntax -- ) builtin-syntax 2array [ @@ -86,7 +86,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; elements get encoding>> swap at elements get tag>> swap at [ - elements get set-element-objtype + elements get (>>objtype) ] when* ] each ; @@ -96,15 +96,15 @@ SYMBOL: end : (read-array) ( -- ) elements get id>> [ - elements get element-syntax read-ber + elements get syntax>> read-ber dup end = [ drop ] [ , (read-array) ] if ] when ; : read-array ( -- array ) [ (read-array) ] { } make ; : set-case ( -- object ) - elements get element-newobj - elements get element-objtype { + elements get newobj>> + elements get objtype>> { { "boolean" [ "\0" = not ] } { "string" [ "" or ] } { "integer" [ be> ] } @@ -112,7 +112,7 @@ SYMBOL: end } case ; : set-id ( -- boolean ) - read1 dup elements get set-element-id ; + read1 dup elements get (>>id) ; : read-ber ( syntax -- object ) element new @@ -124,7 +124,7 @@ SYMBOL: end set-encoding set-content-length set-newobj - elements get element-syntax set-objtype + elements get syntax>> set-objtype set-case ] [ end ] if ; @@ -181,7 +181,7 @@ TUPLE: tag value ; ] with-scope ; inline : set-tag ( value -- ) - tagnum get set-tag-value ; + tagnum get (>>value) ; M: string >ber ( str -- byte-array ) tagnum get tag-value 1array "C" pack-native swap dup diff --git a/extra/benchmark/empty-loop-0/empty-loop-0.factor b/extra/benchmark/empty-loop-0/empty-loop-0.factor index 65390e84f2..1922274cac 100644 --- a/extra/benchmark/empty-loop-0/empty-loop-0.factor +++ b/extra/benchmark/empty-loop-0/empty-loop-0.factor @@ -5,6 +5,6 @@ IN: benchmark.empty-loop-0 dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ; : empty-loop-main ( -- ) - 5000000 empty-loop-0 ; + 50000000 empty-loop-0 ; MAIN: empty-loop-main diff --git a/extra/benchmark/empty-loop-1/empty-loop-1.factor b/extra/benchmark/empty-loop-1/empty-loop-1.factor index 36d8722732..16303b4b4d 100644 --- a/extra/benchmark/empty-loop-1/empty-loop-1.factor +++ b/extra/benchmark/empty-loop-1/empty-loop-1.factor @@ -5,6 +5,6 @@ IN: benchmark.empty-loop-1 [ drop ] each-integer ; : empty-loop-main ( -- ) - 5000000 empty-loop-1 ; + 50000000 empty-loop-1 ; MAIN: empty-loop-main diff --git a/extra/benchmark/empty-loop-2/empty-loop-2.factor b/extra/benchmark/empty-loop-2/empty-loop-2.factor index f7d66b04ab..f09aee6ada 100644 --- a/extra/benchmark/empty-loop-2/empty-loop-2.factor +++ b/extra/benchmark/empty-loop-2/empty-loop-2.factor @@ -5,6 +5,6 @@ IN: benchmark.empty-loop-2 [ drop ] each ; : empty-loop-main ( -- ) - 5000000 empty-loop-2 ; + 50000000 empty-loop-2 ; MAIN: empty-loop-main diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor index 580be0d0ec..c988e5722e 100644 --- a/extra/benchmark/fib4/fib4.factor +++ b/extra/benchmark/fib4/fib4.factor @@ -1,7 +1,7 @@ USING: accessors math kernel debugger ; IN: benchmark.fib4 -TUPLE: box i ; +TUPLE: box { i read-only } ; C: box @@ -15,8 +15,8 @@ C: box i>> 1- tuple-fib swap i>> swap i>> + - ] if ; + ] if ; inline recursive -: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ; +: fib-main ( -- ) T{ box f 34 } tuple-fib i>> 9227465 assert= ; MAIN: fib-main diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor index 3fad3adbaa..3c1f8490c4 100644 --- a/extra/coroutines/coroutines.factor +++ b/extra/coroutines/coroutines.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel hashtables namespaces continuations quotations +accessors ; IN: coroutines -USING: kernel hashtables namespaces continuations quotations ; SYMBOL: current-coro @@ -13,12 +14,12 @@ TUPLE: coroutine resumecc exitcc ; [ swapd , , \ bind , "Coroutine has terminated illegally." , \ throw , ] [ ] make - over set-coroutine-resumecc ; + >>resumecc ; : coresume ( v co -- result ) [ - over set-coroutine-exitcc - coroutine-resumecc call + >>exitcc + resumecc>> call #! At this point, the coroutine quotation must have terminated #! normally (without calling coyield or coterminate). This shouldn't happen. f over @@ -31,8 +32,8 @@ TUPLE: coroutine resumecc exitcc ; current-coro get [ [ continue-with ] curry - over set-coroutine-resumecc - coroutine-exitcc continue-with + >>resumecc + exitcc>> continue-with ] callcc1 2nip ; : coyield* ( v -- ) coyield drop ; inline @@ -40,5 +41,5 @@ TUPLE: coroutine resumecc exitcc ; : coterminate ( v -- ) current-coro get - [ ] over set-coroutine-resumecc - coroutine-exitcc continue-with ; + [ ] >>resumecc + exitcc>> continue-with ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index d14e975ae1..03f424e8d4 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary io.backend db.errors present urls io.encodings.utf8 -io.encodings.string ; +io.encodings.string accessors ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -16,7 +16,7 @@ ERROR: sqlite-sql-error < sql-error n string ; : sqlite-statement-error ( -- * ) SQLITE_ERROR - db get db-handle sqlite3_errmsg sqlite-sql-error ; + db get handle>> sqlite3_errmsg sqlite-sql-error ; : sqlite-check-result ( n -- ) { diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 38a3899fc4..794ff5bacd 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -90,7 +90,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) ] keep bind-statement ; : last-insert-id ( -- id ) - db get db-handle sqlite3_last_insert_rowid + db get handle>> sqlite3_last_insert_rowid dup zero? [ "last-id failed" throw ] when ; M: sqlite-db insert-tuple* ( tuple statement -- ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 71cf878d2f..1b7ab24366 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -141,7 +141,7 @@ M: retryable execute-statement* ( statement type -- ) : update-tuple ( tuple -- ) dup class - db get db-update-statements [ ] cache + db get update-statements>> [ ] cache [ bind-tuple ] keep execute-statement ; : delete-tuples ( tuple -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 3cb17cf08b..47d3727703 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml kernel sequences xml.utilities combinators.lib math xml.data arrays assocs xml.generator xml.writer namespaces -math.parser io ; +math.parser io accessors ; IN: faq : find-after ( seq quot -- elem after ) @@ -21,16 +21,16 @@ C: q/a >r tag-children r> ; : q/a>li ( q/a -- li ) - [ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep - q/a-answer append "li" build-tag* ; + [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep + answer>> append "li" build-tag* ; : xml>q/a ( xml -- q/a ) [ "question" tag-named tag-children ] keep "answer" tag-named tag-children ; : q/a>xml ( q/a -- xml ) - [ q/a-question "question" build-tag* ] keep - q/a-answer "answer" build-tag* + [ question>> "question" build-tag* ] keep + answer>> "answer" build-tag* "\n" swap 3array "qa" build-tag* ; ! Lists of questions @@ -43,23 +43,23 @@ C: question-list ; : question-list>xml ( question-list -- list ) - [ question-list-seq [ q/a>xml "\n" swap 2array ] + [ seq>> [ q/a>xml "\n" swap 2array ] map concat "list" build-tag* ] keep - question-list-title [ "title" pick set-at ] when* ; + title>> [ "title" pick set-at ] when* ; : html>question-list ( h3 ol -- question-list ) >r [ children>string ] [ f ] if* r> children-tags [ li>q/a ] map ; : question-list>h3 ( id question-list -- h3 ) - question-list-title [ + title>> [ "h3" build-tag swap number>string "id" pick set-at ] [ drop f ] if* ; : question-list>html ( question-list start id -- h3/f ol ) -rot >r [ question-list>h3 ] keep - question-list-seq [ q/a>li ] map "ol" build-tag* r> + seq>> [ q/a>li ] map "ol" build-tag* r> number>string "start" pick set-at "margin-left: 5em" "style" pick set-at ; @@ -72,32 +72,32 @@ C: faq first2 >r f prefix r> [ html>question-list ] 2map ; : header, ( faq -- ) - dup faq-header , - faq-lists first 1 -1 question-list>html nip , ; + dup header>> , + lists>> first 1 -1 question-list>html nip , ; : br, ( -- ) "br" contained, nl, ; : toc-link, ( question-list number -- ) number>string "#" prepend "href" swap 2array 1array - "a" swap [ question-list-title , ] tag*, br, ; + "a" swap [ title>> , ] tag*, br, ; : toc, ( faq -- ) "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ "strong" [ "The big questions" , ] tag, br, - faq-lists rest dup length [ toc-link, ] 2each + lists>> rest dup length [ toc-link, ] 2each ] tag*, ; : faq-sections, ( question-lists -- ) - unclip question-list-seq length 1+ dupd - [ question-list-seq length + ] accumulate nip + unclip seq>> length 1+ dupd + [ seq>> length + ] accumulate nip 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ; : faq>html ( faq -- div ) "div" [ dup header, dup toc, - faq-lists faq-sections, + lists>> faq-sections, ] make-xml ; : xml>faq ( xml -- faq ) @@ -106,8 +106,8 @@ C: faq : faq>xml ( faq -- xml ) "faq" [ - "header" [ dup faq-header , ] tag, - faq-lists [ question-list>xml , nl, ] each + "header" [ dup header>> , ] tag, + lists>> [ question-list>xml , nl, ] each ] make-xml ; : read-write-faq ( xml-stream -- ) diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index c5a5449b25..21a32d1776 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -144,7 +144,7 @@ M: ftp-list service-command ( stream obj -- ) 150 "Opening BINARY mode data connection for " rot [ file-name ] [ - " " swap file-info file-info-size number>string + " " swap file-info size>> number>string "(" " bytes)." swapd 3append append ] bi 3append server-response ; diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor index ddd72a4a39..dc6a86017a 100644 --- a/extra/math/blas/matrices/matrices-docs.factor +++ b/extra/math/blas/matrices/matrices-docs.factor @@ -1,4 +1,4 @@ -USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ; +USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ; IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" @@ -52,13 +52,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" { $subsection Mcols } { $subsection Msub } "Matrix-vector products:" -{ $subsection n*M.V+n*V-in-place } +{ $subsection n*M.V+n*V! } { $subsection n*M.V+n*V } { $subsection n*M.V } { $subsection M.V } "Vector outer products:" -{ $subsection n*V(*)V+M-in-place } -{ $subsection n*V(*)Vconj+M-in-place } +{ $subsection n*V(*)V+M! } +{ $subsection n*V(*)Vconj+M! } { $subsection n*V(*)V+M } { $subsection n*V(*)Vconj+M } { $subsection n*V(*)V } @@ -66,12 +66,12 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" { $subsection V(*) } { $subsection V(*)conj } "Matrix products:" -{ $subsection n*M.M+n*M-in-place } +{ $subsection n*M.M+n*M! } { $subsection n*M.M+n*M } { $subsection n*M.M } { $subsection M. } "Scalar-matrix products:" -{ $subsection n*M-in-place } +{ $subsection n*M! } { $subsection n*M } { $subsection M*n } { $subsection M/n } ; @@ -111,134 +111,135 @@ HELP: double-complex-blas-matrix } related-words HELP: Mwidth -{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } } +{ $values { "matrix" blas-matrix-base } { "width" integer } } { $description "Returns the number of columns in " { $snippet "matrix" } "." } ; HELP: Mheight -{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } } +{ $values { "matrix" blas-matrix-base } { "height" integer } } { $description "Returns the number of rows in " { $snippet "matrix" } "." } ; { Mwidth Mheight } related-words -HELP: n*M.V+n*V-in-place -{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } } +HELP: n*M.V+n*V! +{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } } { $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } { $side-effects "y" } ; -HELP: n*V(*)V+M-in-place -{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +HELP: n*V(*)V+M! +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } } { $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." } { $side-effects "A" } ; -HELP: n*V(*)Vconj+M-in-place -{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } } +HELP: n*V(*)Vconj+M! +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } } { $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." } { $side-effects "A" } ; -HELP: n*M.M+n*M-in-place -{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } -{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ; +HELP: n*M.M+n*M! +{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } } +{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } +{ $side-effects "C" } ; HELP: -{ $values { "rows" "the number of rows the new matrix will have" } { "cols" "the number of columns the new matrix will have" } { "exemplar" "A BLAS vector inherited from " { $link blas-vector-base } " or BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } } { $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ; { } related-words HELP: n*M.V+n*V -{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } } { $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ; HELP: n*V(*)V+M -{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } } { $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; HELP: n*V(*)Vconj+M -{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } } { $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ; HELP: n*M.M+n*M -{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } } { $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ; HELP: n*M.V -{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } } { $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ; HELP: M.V -{ $values { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } } { $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ; -{ n*M.V+n*V-in-place n*M.V+n*V n*M.V M.V } related-words +{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words HELP: n*V(*)V -{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } } { $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; HELP: n*V(*)Vconj -{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } } { $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ; HELP: V(*) -{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } } { $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; HELP: V(*)conj -{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } } { $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ; -{ n*V(*)V+M-in-place n*V(*)Vconj+M-in-place n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words +{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words HELP: n*M.M -{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } } { $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ; HELP: M. -{ $values { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } } { $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ; -{ n*M.M+n*M-in-place n*M.M+n*M n*M.M M. } related-words +{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words HELP: Msub -{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "row" "The topmost row of the slice" } { "col" "The leftmost column of the slice" } { "height" "The height of the slice" } { "width" "The width of the slice" } } +{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } } { $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ; HELP: Mrows -{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $values { "A" blas-matrix-base } { "rows" sequence } } { $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ; HELP: Mcols -{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $values { "A" blas-matrix-base } { "cols" sequence } } { $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ; -HELP: n*M-in-place -{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +HELP: n*M! +{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } } { $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." } { $side-effects "A" } ; HELP: n*M -{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } } { $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; HELP: M*n -{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } } +{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } } { $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; HELP: M/n -{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } } +{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } } { $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; -{ n*M-in-place n*M M*n M/n } related-words +{ n*M! n*M M*n M/n } related-words HELP: Mtranspose -{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } } { $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ; HELP: element-type -{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } } { $description "Return the C type of the elements in the given BLAS vector or matrix." } ; HELP: -{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } -{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ; +{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } } +{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ; diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index c8e55c4ec0..4f50543e73 100755 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -153,41 +153,45 @@ PRIVATE> [ (flatten-complex-sequence) >c-double-array ] (>matrix) ; -GENERIC: n*M.V+n*V-in-place ( alpha A x beta y -- y=alpha*A.x+b*y ) -GENERIC: n*V(*)V+M-in-place ( alpha x y A -- A=alpha*x(*)y+A ) -GENERIC: n*V(*)Vconj+M-in-place ( alpha x y A -- A=alpha*x(*)yconj+A ) -GENERIC: n*M.M+n*M-in-place ( alpha A B beta C -- C=alpha*A.B+beta*C ) +GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y ) +GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A ) +GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A ) +GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) -METHOD: n*M.V+n*V-in-place { real float-blas-matrix float-blas-vector real float-blas-vector } +METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector } [ ] (prepare-gemv) [ cblas_sgemv ] dip ; -METHOD: n*M.V+n*V-in-place { real double-blas-matrix double-blas-vector real double-blas-vector } +METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector } [ ] (prepare-gemv) [ cblas_dgemv ] dip ; -METHOD: n*M.V+n*V-in-place { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector } +METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector } [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ; -METHOD: n*M.V+n*V-in-place { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector } +METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector } [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ; -METHOD: n*V(*)V+M-in-place { real float-blas-vector float-blas-vector float-blas-matrix } +METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix } [ ] (prepare-ger) [ cblas_sger ] dip ; -METHOD: n*V(*)V+M-in-place { real double-blas-vector double-blas-vector double-blas-matrix } +METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix } [ ] (prepare-ger) [ cblas_dger ] dip ; -METHOD: n*V(*)V+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } +METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ; -METHOD: n*V(*)V+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } +METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ; -METHOD: n*V(*)Vconj+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } +METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix } + [ ] (prepare-ger) [ cblas_sger ] dip ; +METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix } + [ ] (prepare-ger) [ cblas_dger ] dip ; +METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ; -METHOD: n*V(*)Vconj+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } +METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ; -METHOD: n*M.M+n*M-in-place { real float-blas-matrix float-blas-matrix real float-blas-matrix } +METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix } [ ] (prepare-gemm) [ cblas_sgemm ] dip ; -METHOD: n*M.M+n*M-in-place { real double-blas-matrix double-blas-matrix real double-blas-matrix } +METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix } [ ] (prepare-gemm) [ cblas_dgemm ] dip ; -METHOD: n*M.M+n*M-in-place { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix } +METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix } [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ; -METHOD: n*M.M+n*M-in-place { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix } +METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix } [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ; ! XXX should do a dense clone @@ -206,36 +210,36 @@ syntax:M: blas-matrix-base clone [ f swap (blas-matrix-like) ] 3tri ; : n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y ) - clone n*M.V+n*V-in-place ; + clone n*M.V+n*V! ; : n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A ) - clone n*V(*)V+M-in-place ; + clone n*V(*)V+M! ; : n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A ) - clone n*V(*)Vconj+M-in-place ; + clone n*V(*)Vconj+M! ; : n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C ) - clone n*M.M+n*M-in-place ; + clone n*M.M+n*M! ; : n*M.V ( alpha A x -- alpha*A.x ) 1.0 2over [ Mheight ] dip - n*M.V+n*V-in-place ; inline + n*M.V+n*V! ; inline : M.V ( A x -- A.x ) 1.0 -rot n*M.V ; inline -: n*V(*)V ( n x y -- n*x(*)y ) +: n*V(*)V ( alpha x y -- alpha*x(*)y ) 2dup [ length>> ] bi@ pick - n*V(*)V+M-in-place ; -: n*V(*)Vconj ( n x y -- n*x(*)yconj ) + n*V(*)V+M! ; +: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj ) 2dup [ length>> ] bi@ pick - n*V(*)Vconj+M-in-place ; + n*V(*)Vconj+M! ; : V(*) ( x y -- x(*)y ) 1.0 -rot n*V(*)V ; inline : V(*)conj ( x y -- x(*)yconj ) 1.0 -rot n*V(*)Vconj ; inline -: n*M.M ( n A B -- n*A.B ) +: n*M.M ( alpha A B -- alpha*A.B ) 2dup [ Mheight ] [ Mwidth ] bi* pick - 1.0 swap n*M.M+n*M-in-place ; + 1.0 swap n*M.M+n*M! ; : M. ( A B -- A.B ) 1.0 -rot n*M.M ; inline @@ -247,7 +251,7 @@ syntax:M: blas-matrix-base clone height width ; -: Msub ( matrix row col height width -- submatrix ) +: Msub ( matrix row col height width -- sub ) 5 npick dup transpose>> [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep swap (blas-matrix-like) ; @@ -281,14 +285,14 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe : Mrows ( A -- rows ) dup transpose>> [ (Mcols) ] [ (Mrows) ] if ; -: Mcols ( A -- rows ) +: Mcols ( A -- cols ) dup transpose>> [ (Mrows) ] [ (Mcols) ] if ; -: n*M-in-place ( n A -- A=n*A ) - [ (Mcols) [ n*V-in-place drop ] with each ] keep ; +: n*M! ( n A -- A=n*A ) + [ (Mcols) [ n*V! drop ] with each ] keep ; : n*M ( n A -- n*A ) - clone n*M-in-place ; inline + clone n*M! ; inline : M*n ( A n -- A*n ) swap n*M ; inline diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor index 4fad9c7378..0595f00989 100644 --- a/extra/math/blas/vectors/vectors-docs.factor +++ b/extra/math/blas/vectors/vectors-docs.factor @@ -1,4 +1,4 @@ -USING: alien byte-arrays help.markup help.syntax sequences ; +USING: alien byte-arrays help.markup help.syntax math sequences ; IN: math.blas.vectors ARTICLE: "math.blas.vectors" "BLAS interface vector operations" @@ -11,13 +11,13 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations" { $subsection Viamax } { $subsection Vamax } "Scalar-vector products:" -{ $subsection n*V-in-place } +{ $subsection n*V! } { $subsection n*V } { $subsection V*n } { $subsection V/n } { $subsection Vneg } "Vector addition:" -{ $subsection n*V+V-in-place } +{ $subsection n*V+V! } { $subsection n*V+V } { $subsection V+ } { $subsection V- } @@ -51,81 +51,81 @@ HELP: float-complex-blas-vector HELP: double-complex-blas-vector { $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: n*V+V-in-place -{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +HELP: n*V+V! +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } { $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." } { $side-effects "y" } ; -HELP: n*V-in-place -{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +HELP: n*V! +{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } } { $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." } { $side-effects "x" } ; HELP: V. -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } } { $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ; HELP: V.conj -{ $values { "x" "a complex BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a complex BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } } { $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ; HELP: Vnorm -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "norm" number } } { $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ; HELP: Vasum -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "sum" number } } { $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ; HELP: Vswap -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } } { $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." } { $side-effects "x" "y" } ; HELP: Viamax -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "max-i" integer } } { $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ; HELP: Vamax -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "max" number } } { $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ; { Viamax Vamax } related-words HELP: -{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } } { $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link } "." } ; HELP: n*V+V -{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } } { $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; HELP: n*V -{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } } { $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; HELP: V+ -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } } { $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; HELP: V- -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } } { $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; HELP: Vneg -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } -{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result." } ; +{ $values { "x" blas-vector-base } { "-x" blas-vector-base } } +{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ; HELP: V*n -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } } +{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } } { $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; HELP: V/n -{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } } +{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } } { $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; -{ n*V+V-in-place n*V-in-place n*V+V n*V V+ V- Vneg V*n V/n } related-words +{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words HELP: Vsub -{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } } { "start" "The index of the first element of the slice" } { "length" "The length of the slice" } } -{ $description "Slice a subvector out of " { $snippet "v" } " with the given length. The subvector will share storage with the parent vector." } ; +{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } } +{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ; diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index 18370f12c0..87bc6437c3 100755 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -21,8 +21,8 @@ C: double-blas-vector C: float-complex-blas-vector C: double-complex-blas-vector -GENERIC: n*V+V-in-place ( alpha x y -- y=alpha*x+y ) -GENERIC: n*V-in-place ( alpha x -- x=alpha*x ) +GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y ) +GENERIC: n*V! ( alpha x -- x=alpha*x ) GENERIC: V. ( x y -- x.y ) GENERIC: V.conj ( x y -- xconj.y ) @@ -202,30 +202,30 @@ METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector } METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector } (prepare-swap) [ cblas_zswap ] 2dip ; -METHOD: n*V+V-in-place { real float-blas-vector float-blas-vector } +METHOD: n*V+V! { real float-blas-vector float-blas-vector } (prepare-axpy) [ cblas_saxpy ] dip ; -METHOD: n*V+V-in-place { real double-blas-vector double-blas-vector } +METHOD: n*V+V! { real double-blas-vector double-blas-vector } (prepare-axpy) [ cblas_daxpy ] dip ; -METHOD: n*V+V-in-place { number float-complex-blas-vector float-complex-blas-vector } +METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector } [ (>c-complex) ] 2dip (prepare-axpy) [ cblas_caxpy ] dip ; -METHOD: n*V+V-in-place { number double-complex-blas-vector double-complex-blas-vector } +METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector } [ (>z-complex) ] 2dip (prepare-axpy) [ cblas_zaxpy ] dip ; -METHOD: n*V-in-place { real float-blas-vector } +METHOD: n*V! { real float-blas-vector } (prepare-scal) [ cblas_sscal ] dip ; -METHOD: n*V-in-place { real double-blas-vector } +METHOD: n*V! { real double-blas-vector } (prepare-scal) [ cblas_dscal ] dip ; -METHOD: n*V-in-place { number float-complex-blas-vector } +METHOD: n*V! { number float-complex-blas-vector } [ (>c-complex) ] dip (prepare-scal) [ cblas_cscal ] dip ; -METHOD: n*V-in-place { number double-complex-blas-vector } +METHOD: n*V! { number double-complex-blas-vector } [ (>z-complex) ] dip (prepare-scal) [ cblas_zscal ] dip ; -: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V-in-place ; inline -: n*V ( alpha x -- alpha*x ) clone n*V-in-place ; inline +: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline +: n*V ( alpha x -- alpha*x ) clone n*V! ; inline : V+ ( x y -- x+y ) 1.0 -rot n*V+V ; inline @@ -251,6 +251,10 @@ METHOD: V. { double-complex-blas-vector double-complex-blas-vector } (prepare-dot) "CBLAS_Z" [ cblas_zdotu_sub ] keep (z-complex>) ; +METHOD: V.conj { float-blas-vector float-blas-vector } + (prepare-dot) cblas_sdot ; +METHOD: V.conj { double-blas-vector double-blas-vector } + (prepare-dot) cblas_ddot ; METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector } (prepare-dot) "CBLAS_C" [ cblas_cdotc_sub ] keep (c-complex>) ; @@ -288,7 +292,7 @@ METHOD: Viamax { double-complex-blas-vector } : Vamax ( x -- max ) [ Viamax ] keep nth ; inline -: Vsub ( v start length -- vsub ) +: Vsub ( v start length -- sub ) rot [ [ nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index b9d997c038..f836d71a99 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: bit-arrays kernel lists.lazy math math.functions math.primes.list - math.ranges sequences ; + math.ranges sequences accessors ; IN: math.erato r ind r> erato-bits nth ; inline + >r ind r> bits>> nth ; inline : indices ( n erato -- range ) - erato-limit ind over 3 * ind swap rot ; + limit>> ind over 3 * ind swap rot ; : mark-multiples ( n erato -- ) - over sq over erato-limit <= - [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ; + over sq over limit>> <= + [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ; : ( n -- erato ) dup ind 1+ 1 over set-bits erato boa ; : next-prime ( erato -- prime/f ) - [ erato-latest 2 + ] keep [ set-erato-latest ] 2keep - 2dup erato-limit <= + [ 2 + ] change-latest [ latest>> ] keep + 2dup limit>> <= [ 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if ] [ diff --git a/extra/odbc/odbc.factor b/extra/odbc/odbc.factor index 5faca7109a..faa6c48354 100644 --- a/extra/odbc/odbc.factor +++ b/extra/odbc/odbc.factor @@ -213,7 +213,7 @@ C: column ] if ; : dereference-type-pointer ( byte-array column -- object ) - column-type { + type>> { { SQL-CHAR [ ascii alien>string ] } { SQL-VARCHAR [ ascii alien>string ] } { SQL-LONGVARCHAR [ ascii alien>string ] } @@ -235,7 +235,7 @@ TUPLE: field value column ; C: field : odbc-get-field ( statement column -- field ) - dup column? [ dupd odbc-describe-column ] unless dup >r column-number + dup column? [ dupd odbc-describe-column ] unless dup >r number>> SQL-C-DEFAULT 8192 CHAR: \space ascii string>alien dup >r 8192 @@ -244,15 +244,15 @@ C: field ] [ r> drop r> [ "SQLGetData Failed for Column: " % - dup column-name % - " of type: " % dup column-type name>> % + dup name>> % + " of type: " % dup type>> name>> % ] "" make swap ] if ; : odbc-get-row-fields ( statement -- seq ) [ dup odbc-number-of-columns [ - 1+ odbc-get-field field-value , + 1+ odbc-get-field value>> , ] with each ] { } make ; diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor index 8ef169810a..e61a47a859 100644 --- a/extra/oracle/oracle.factor +++ b/extra/oracle/oracle.factor @@ -6,7 +6,7 @@ USING: alien alien.c-types alien.strings combinators kernel math namespaces oracle.liboci prettyprint sequences -io.encodings.ascii ; +io.encodings.ascii accessors ; IN: oracle @@ -102,9 +102,9 @@ C: connection : oci-log-on ( -- ) env get err get svc get - con get connection-username dup length swap ascii malloc-string swap - con get connection-password dup length swap ascii malloc-string swap - con get connection-db dup length swap ascii malloc-string swap + con get username>> dup length swap ascii malloc-string swap + con get password>> dup length swap ascii malloc-string swap + con get db>> dup length swap ascii malloc-string swap OCILogon check-result ; ! ========================================================= @@ -112,18 +112,18 @@ C: connection ! ========================================================= : attach-to-server ( -- ) - srv get err get con get connection-db dup length OCI_DEFAULT + srv get err get con get db>> dup length OCI_DEFAULT OCIServerAttach check-result ; : set-service-attribute ( -- ) svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ; : set-username-attribute ( -- ) - ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap + ses get OCI_HTYPE_SESSION con get username>> dup length swap ascii malloc-string swap OCI_ATTR_USERNAME err get OCIAttrSet check-result ; : set-password-attribute ( -- ) - ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap + ses get OCI_HTYPE_SESSION con get password>> dup length swap ascii malloc-string swap OCI_ATTR_PASSWORD err get OCIAttrSet check-result ; : set-attributes ( -- ) diff --git a/extra/db/mysql/ffi/ffi.factor b/unmaintained/db/mysql/ffi/ffi.factor similarity index 100% rename from extra/db/mysql/ffi/ffi.factor rename to unmaintained/db/mysql/ffi/ffi.factor diff --git a/extra/db/mysql/lib/lib.factor b/unmaintained/db/mysql/lib/lib.factor similarity index 96% rename from extra/db/mysql/lib/lib.factor rename to unmaintained/db/mysql/lib/lib.factor index ca912f200d..db8c08180b 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/unmaintained/db/mysql/lib/lib.factor @@ -3,7 +3,7 @@ ! Adapted from mysql.h and mysql.c ! Tested with MySQL version - 5.0.24a USING: kernel alien io prettyprint sequences -namespaces arrays math db.mysql.ffi system ; +namespaces arrays math db.mysql.ffi system accessors ; IN: db.mysql.lib SYMBOL: my-conn @@ -34,7 +34,7 @@ TUPLE: mysql-result-set ; ! ========================================================= : (mysql-query) ( mysql-connection query -- ret ) - >r mysql-db-handle r> mysql_query ; + >r db-handle>> r> mysql_query ; ! : (mysql-result) ( mysql-connection -- ret ) ! [ mysql-db-handle mysql_use_result ] keep diff --git a/extra/db/mysql/mysql.factor b/unmaintained/db/mysql/mysql.factor similarity index 100% rename from extra/db/mysql/mysql.factor rename to unmaintained/db/mysql/mysql.factor