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.
 | 
			
		||||
! 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 [-]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue