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." } ;
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." } ;
HELP: >bit vector
{ $values { "seq" "a sequence" } { "vector" vector } }
HELP: >bit-vector
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
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 <vector> dup do-it sequence=
] unit-test
[ t ] [ ?V{ } bit-vector? ] unit-test

View File

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

View File

@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
";"
"<PRIVATE"
"?{"
"?V{"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"F{"
"FV{"
"FORGET:"
"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." } ;
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." } ;
HELP: >byte-vector

View File

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

View File

@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics
{ +output+ { "out" } }
} 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-accessor ( quot -- )
"offset" operand dup %untag-fixnum

View File

@ -586,43 +586,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "wrapper" } }
} 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-accessor ( quot -- )
"offset" operand dup %untag-fixnum

View File

@ -447,45 +447,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "wrapper" } }
} 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-accessor ( quot -- )
"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." } ;
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." } ;
HELP: >float-vector

View File

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

View File

@ -6,7 +6,7 @@ IN: float-vectors
<PRIVATE
: float-array>vector ( float-array -- float-vector )
: float-array>vector ( float-array length -- float-vector )
float-vector construct-boa ; inline
PRIVATE>
@ -23,7 +23,7 @@ M: float-vector like
] unless ;
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?
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" } }
{ $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
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
{ $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
\ 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 make-foldable
@ -491,12 +488,18 @@ t over set-effect-terminated?
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
\ 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 make-flushable
\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
\ (hashtable) make-flushable
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
\ <array> make-flushable
@ -532,9 +535,6 @@ t over set-effect-terminated?
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
\ (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> 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.
USING: arrays byte-arrays bit-arrays generic hashtables io
assocs kernel math namespaces sequences strings sbufs io.styles
vectors words prettyprint.config prettyprint.sections quotations
io io.files math.parser effects tuples classes float-arrays ;
USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
tuples classes float-arrays float-vectors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -143,8 +144,11 @@ M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
M: float-vector pprint-delims drop \ FV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
@ -156,6 +160,9 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >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: tuple >pprint-sequence tuple>array ;
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.
USING: alien arrays bit-arrays byte-arrays definitions generic
hashtables kernel math namespaces parser sequences strings sbufs
vectors words quotations io assocs splitting tuples
generic.standard generic.math classes io.files vocabs
float-arrays classes.union classes.mixin classes.predicate
compiler.units ;
USING: alien arrays bit-arrays bit-vectors byte-arrays
byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -71,8 +71,11 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax