add alternate literal syntax "X-array@ PTR LEN" for direct-arrays. pprint with this syntax when c-object-pointers? prettyprint flag is set, or the pointer under the direct-array is invalid
parent
0f1270720d
commit
dee9f56500
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays byte-arrays byte-vectors generic hashtables
|
USING: accessors arrays byte-arrays byte-vectors continuations
|
||||||
assocs kernel math namespaces make sequences strings sbufs vectors
|
generic hashtables assocs kernel math namespaces make sequences
|
||||||
words prettyprint.config prettyprint.custom prettyprint.sections
|
strings sbufs vectors words prettyprint.config prettyprint.custom
|
||||||
quotations io io.pathnames io.styles math.parser effects classes.tuple
|
prettyprint.sections quotations io io.pathnames io.styles math.parser
|
||||||
math.order classes.tuple.private classes combinators colors ;
|
effects classes.tuple math.order classes.tuple.private classes
|
||||||
|
combinators colors ;
|
||||||
IN: prettyprint.backend
|
IN: prettyprint.backend
|
||||||
|
|
||||||
M: effect pprint* effect>string "(" ")" surround text ;
|
M: effect pprint* effect>string "(" ")" surround text ;
|
||||||
|
@ -153,6 +154,11 @@ M: pathname pprint*
|
||||||
M: tuple pprint*
|
M: tuple pprint*
|
||||||
pprint-tuple ;
|
pprint-tuple ;
|
||||||
|
|
||||||
|
: pprint-c-object ( object content-quot pointer-quot -- )
|
||||||
|
[ c-object-pointers? get ] 2dip
|
||||||
|
[ nip ]
|
||||||
|
[ [ drop ] prepose [ recover ] 2curry ] 2bi if ; inline
|
||||||
|
|
||||||
: do-length-limit ( seq -- trimmed n/f )
|
: do-length-limit ( seq -- trimmed n/f )
|
||||||
length-limit get dup [
|
length-limit get dup [
|
||||||
over length over [-]
|
over length over [-]
|
||||||
|
|
|
@ -13,6 +13,7 @@ SYMBOL: length-limit
|
||||||
SYMBOL: line-limit
|
SYMBOL: line-limit
|
||||||
SYMBOL: string-limit?
|
SYMBOL: string-limit?
|
||||||
SYMBOL: boa-tuples?
|
SYMBOL: boa-tuples?
|
||||||
|
SYMBOL: c-object-pointers?
|
||||||
|
|
||||||
4 tab-size set-global
|
4 tab-size set-global
|
||||||
64 margin set-global
|
64 margin set-global
|
||||||
|
|
|
@ -2,9 +2,17 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: functors sequences sequences.private kernel words classes
|
USING: functors sequences sequences.private kernel words classes
|
||||||
math alien alien.c-types byte-arrays accessors
|
math alien alien.c-types byte-arrays accessors
|
||||||
specialized-arrays prettyprint.custom ;
|
specialized-arrays parser prettyprint.backend prettyprint.custom ;
|
||||||
IN: specialized-arrays.direct.functor
|
IN: specialized-arrays.direct.functor
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: pprint-direct-array ( direct-array tag -- )
|
||||||
|
pprint-word
|
||||||
|
[ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
FUNCTOR: define-direct-array ( T -- )
|
FUNCTOR: define-direct-array ( T -- )
|
||||||
|
|
||||||
A' IS ${T}-array
|
A' IS ${T}-array
|
||||||
|
@ -15,6 +23,7 @@ A'{ IS ${A'}{
|
||||||
|
|
||||||
A DEFINES-CLASS direct-${T}-array
|
A DEFINES-CLASS direct-${T}-array
|
||||||
<A> DEFINES <${A}>
|
<A> DEFINES <${A}>
|
||||||
|
A'@ DEFINES ${A'}@
|
||||||
|
|
||||||
NTH [ T dup c-type-getter-boxer array-accessor ]
|
NTH [ T dup c-type-getter-boxer array-accessor ]
|
||||||
SET-NTH [ T dup c-setter array-accessor ]
|
SET-NTH [ T dup c-setter array-accessor ]
|
||||||
|
@ -34,11 +43,17 @@ M: A new-sequence drop <A'> ; inline
|
||||||
|
|
||||||
M: A byte-length length>> T heap-size * ; inline
|
M: A byte-length length>> T heap-size * ; inline
|
||||||
|
|
||||||
|
SYNTAX: A'@
|
||||||
|
scan-object scan-object <A> parsed ;
|
||||||
|
|
||||||
M: A pprint-delims drop \ A'{ \ } ;
|
M: A pprint-delims drop \ A'{ \ } ;
|
||||||
|
|
||||||
M: A >pprint-sequence ;
|
M: A >pprint-sequence ;
|
||||||
|
|
||||||
M: A pprint* pprint-object ;
|
M: A pprint*
|
||||||
|
[ pprint-object ]
|
||||||
|
[ \ A'@ pprint-direct-array ]
|
||||||
|
pprint-c-object ;
|
||||||
|
|
||||||
INSTANCE: A sequence
|
INSTANCE: A sequence
|
||||||
INSTANCE: A S
|
INSTANCE: A S
|
||||||
|
|
Loading…
Reference in New Issue