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

db4
Joe Groff 2009-08-30 20:23:55 -05:00
parent 0f1270720d
commit dee9f56500
3 changed files with 29 additions and 7 deletions

View File

@ -1,10 +1,11 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays byte-vectors generic hashtables
assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
quotations io io.pathnames io.styles math.parser effects classes.tuple
math.order classes.tuple.private classes combinators colors ;
USING: accessors arrays byte-arrays byte-vectors continuations
generic hashtables assocs kernel math namespaces make sequences
strings sbufs vectors words prettyprint.config prettyprint.custom
prettyprint.sections quotations io io.pathnames io.styles math.parser
effects classes.tuple math.order classes.tuple.private classes
combinators colors ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -153,6 +154,11 @@ M: pathname pprint*
M: tuple pprint*
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 )
length-limit get dup [
over length over [-]

View File

@ -13,6 +13,7 @@ SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: string-limit?
SYMBOL: boa-tuples?
SYMBOL: c-object-pointers?
4 tab-size set-global
64 margin set-global

View File

@ -2,9 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
specialized-arrays prettyprint.custom ;
specialized-arrays parser prettyprint.backend prettyprint.custom ;
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 -- )
A' IS ${T}-array
@ -15,6 +23,7 @@ A'{ IS ${A'}{
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
A'@ DEFINES ${A'}@
NTH [ T dup c-type-getter-boxer 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
SYNTAX: A'@
scan-object scan-object <A> parsed ;
M: A pprint-delims drop \ A'{ \ } ;
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 S