Assorted fixes

db4
Slava Pestov 2008-01-30 01:10:58 -06:00
parent d11203cf28
commit f73f2b8697
16 changed files with 48 additions and 144 deletions

View File

@ -20,11 +20,11 @@ HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; { $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
HELP: <bit-vector> HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit vector HELP: >bit-vector
{ $values { "seq" "a sequence" } { "vector" vector } } { $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: bit-array>vector HELP: bit-array>vector

View File

@ -10,3 +10,5 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
3 <bit-vector> dup do-it 3 <bit-vector> dup do-it
3 <vector> dup do-it sequence= 3 <vector> dup do-it sequence=
] unit-test ] unit-test
[ t ] [ ?V{ } bit-vector? ] unit-test

View File

@ -6,7 +6,7 @@ IN: bit-vectors
<PRIVATE <PRIVATE
: bit-array>vector ( bit-array -- bit-vector ) : bit-array>vector ( bit-array length -- bit-vector )
bit-vector construct-boa ; inline bit-vector construct-boa ; inline
PRIVATE> PRIVATE>

View File

@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
";" ";"
"<PRIVATE" "<PRIVATE"
"?{" "?{"
"?V{"
"BIN:" "BIN:"
"B{" "B{"
"BV{"
"C:" "C:"
"CHAR:" "CHAR:"
"DEFER:" "DEFER:"
"F{" "F{"
"FV{"
"FORGET:" "FORGET:"
"GENERIC#" "GENERIC#"
"GENERIC:" "GENERIC:"

View File

@ -20,7 +20,7 @@ HELP: byte-vector
{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; { $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
HELP: <byte-vector> HELP: <byte-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; { $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
HELP: >byte-vector HELP: >byte-vector

View File

@ -10,3 +10,5 @@ USING: tools.test byte-vectors vectors sequences kernel ;
3 <byte-vector> do-it 3 <byte-vector> do-it
3 <vector> do-it sequence= 3 <vector> do-it sequence=
] unit-test ] unit-test
[ t ] [ BV{ } byte-vector? ] unit-test

View File

@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics
{ +output+ { "out" } } { +output+ { "out" } }
} define-intrinsic } define-intrinsic
\ (hashtable) [
hashtable 4 cells %allot
R12 f v>operand MOV
R12 1 %set-slot
R12 2 %set-slot
R12 3 %set-slot
! Store tagged ptr in reg
"out" get object %store-tagged
] H{
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ string>sbuf [
sbuf 3 cells %allot
"length" operand 1 %set-slot
"string" operand 2 %set-slot
"out" get object %store-tagged
] H{
{ +input+ { { f "string" } { f "length" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ array>vector [
vector 3 cells %allot
"length" operand 1 %set-slot
"array" operand 2 %set-slot
"out" get object %store-tagged
] H{
{ +input+ { { f "array" } { f "length" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
! Alien intrinsics ! Alien intrinsics
: %alien-accessor ( quot -- ) : %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum "offset" operand dup %untag-fixnum

View File

@ -586,43 +586,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "wrapper" } } { +output+ { "wrapper" } }
} define-intrinsic } define-intrinsic
\ (hashtable) [
hashtable 4 cells %allot
f v>operand 12 LI
12 11 1 cells STW
12 11 2 cells STW
12 11 3 cells STW
! Store tagged ptr in reg
"hashtable" get object %store-tagged
] H{
{ +scratch+ { { f "hashtable" } } }
{ +output+ { "hashtable" } }
} define-intrinsic
\ string>sbuf [
sbuf 3 cells %allot
"length" operand 11 1 cells STW
"string" operand 11 2 cells STW
! Store tagged ptr in reg
"sbuf" get object %store-tagged
] H{
{ +input+ { { f "string" } { f "length" } } }
{ +scratch+ { { f "sbuf" } } }
{ +output+ { "sbuf" } }
} define-intrinsic
\ array>vector [
vector 3 cells %allot
"length" operand 11 1 cells STW
"array" operand 11 2 cells STW
! Store tagged ptr in reg
"vector" get object %store-tagged
] H{
{ +input+ { { f "array" } { f "length" } } }
{ +scratch+ { { f "vector" } } }
{ +output+ { "vector" } }
} define-intrinsic
! Alien intrinsics ! Alien intrinsics
: %alien-accessor ( quot -- ) : %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum "offset" operand dup %untag-fixnum

View File

@ -447,45 +447,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "wrapper" } } { +output+ { "wrapper" } }
} define-intrinsic } define-intrinsic
\ (hashtable) [
hashtable 4 cells [
1 object@ f v>operand MOV
2 object@ f v>operand MOV
3 object@ f v>operand MOV
! Store tagged ptr in reg
"hashtable" get object %store-tagged
] %allot
] H{
{ +scratch+ { { f "hashtable" } } }
{ +output+ { "hashtable" } }
} define-intrinsic
\ string>sbuf [
sbuf 3 cells [
1 object@ "length" operand MOV
2 object@ "string" operand MOV
! Store tagged ptr in reg
"sbuf" get object %store-tagged
] %allot
] H{
{ +input+ { { f "string" } { f "length" } } }
{ +scratch+ { { f "sbuf" } } }
{ +output+ { "sbuf" } }
} define-intrinsic
\ array>vector [
vector 3 cells [
1 object@ "length" operand MOV
2 object@ "array" operand MOV
! Store tagged ptr in reg
"vector" get object %store-tagged
] %allot
] H{
{ +input+ { { f "array" } { f "length" } } }
{ +scratch+ { { f "vector" } } }
{ +output+ { "vector" } }
} define-intrinsic
! Alien intrinsics ! Alien intrinsics
: %alien-accessor ( quot -- ) : %alien-accessor ( quot -- )
"offset" operand %untag-fixnum "offset" operand %untag-fixnum

View File

@ -20,7 +20,7 @@ HELP: float-vector
{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; { $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
HELP: <float-vector> HELP: <float-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; { $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;
HELP: >float-vector HELP: >float-vector

View File

@ -10,3 +10,5 @@ USING: tools.test float-vectors vectors sequences kernel ;
3 <float-vector> do-it 3 <float-vector> do-it
3 <vector> do-it sequence= 3 <vector> do-it sequence=
] unit-test ] unit-test
[ t ] [ FV{ } float-vector? ] unit-test

View File

@ -6,7 +6,7 @@ IN: float-vectors
<PRIVATE <PRIVATE
: float-array>vector ( float-array -- float-vector ) : float-array>vector ( float-array length -- float-vector )
float-vector construct-boa ; inline float-vector construct-boa ; inline
PRIVATE> PRIVATE>
@ -23,7 +23,7 @@ M: float-vector like
] unless ; ] unless ;
M: float-vector new M: float-vector new
drop [ <float-array> ] keep >fixnum float-array>vector ; drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
M: float-vector equal? M: float-vector equal?
over float-vector? [ sequence= ] [ 2drop f ] if ; over float-vector? [ sequence= ] [ 2drop f ] if ;

View File

@ -116,10 +116,6 @@ HELP: <hashtable>
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } } { $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } }
{ $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ; { $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ;
HELP: (hashtable) ( -- hash )
{ $values { "hash" "a new hashtable" } }
{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link <hashtable> } " instead." } ;
HELP: associate HELP: associate
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } } { $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
{ $description "Create a new hashtable holding one key/value pair." } ; { $description "Create a new hashtable holding one key/value pair." } ;

View File

@ -167,9 +167,6 @@ t over set-effect-terminated?
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop \ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
\ string>sbuf make-flushable
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop \ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
\ bignum>fixnum make-foldable \ bignum>fixnum make-foldable
@ -491,12 +488,18 @@ t over set-effect-terminated?
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop \ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ resize-array make-flushable \ resize-array make-flushable
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
\ resize-byte-array make-flushable
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
\ resize-bit-array make-flushable
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
\ resize-float-array make-flushable
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop \ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
\ resize-string make-flushable \ resize-string make-flushable
\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
\ (hashtable) make-flushable
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop \ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
\ <array> make-flushable \ <array> make-flushable
@ -532,9 +535,6 @@ t over set-effect-terminated?
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop \ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
\ (clone) make-flushable \ (clone) make-flushable
\ array>vector { array integer } { vector } <effect> "inferred-effect" set-word-prop
\ array>vector make-flushable
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop \ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
\ <string> make-flushable \ <string> make-flushable

View File

@ -1,9 +1,10 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays bit-arrays generic hashtables io USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
assocs kernel math namespaces sequences strings sbufs io.styles generic hashtables io assocs kernel math namespaces sequences
vectors words prettyprint.config prettyprint.sections quotations strings sbufs io.styles vectors words prettyprint.config
io io.files math.parser effects tuples classes float-arrays ; prettyprint.sections quotations io io.files math.parser effects
tuples classes float-arrays float-vectors ;
IN: prettyprint.backend IN: prettyprint.backend
GENERIC: pprint* ( obj -- ) GENERIC: pprint* ( obj -- )
@ -143,8 +144,11 @@ M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ; M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ; M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ; M: float-array pprint-delims drop \ F{ \ } ;
M: float-vector pprint-delims drop \ FV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ; M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ; M: tuple pprint-delims drop \ T{ \ } ;
@ -156,6 +160,9 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ; M: object >pprint-sequence ;
M: vector >pprint-sequence ; M: vector >pprint-sequence ;
M: bit-vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: float-vector >pprint-sequence ;
M: hashtable >pprint-sequence >alist ; M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ; M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped 1array ; M: wrapper >pprint-sequence wrapped 1array ;

View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays definitions generic USING: alien arrays bit-arrays bit-vectors byte-arrays
hashtables kernel math namespaces parser sequences strings sbufs byte-vectors definitions generic hashtables kernel math
vectors words quotations io assocs splitting tuples namespaces parser sequences strings sbufs vectors words
generic.standard generic.math classes io.files vocabs quotations io assocs splitting tuples generic.standard
float-arrays classes.union classes.mixin classes.predicate generic.math classes io.files vocabs float-arrays float-vectors
compiler.units ; classes.union classes.mixin classes.predicate compiler.units ;
IN: bootstrap.syntax IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with ! These words are defined as a top-level form, instead of with
@ -71,8 +71,11 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax "{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax