Merge branch 'master' into fortran
commit
da05150686
23
Makefile
23
Makefile
|
@ -17,11 +17,12 @@ else
|
|||
CFLAGS += -O3 $(SITE_CFLAGS)
|
||||
endif
|
||||
|
||||
CONFIG = $(shell ./build-support/factor.sh config-target)
|
||||
include $(CONFIG)
|
||||
|
||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||
|
||||
ifdef CONFIG
|
||||
include $(CONFIG)
|
||||
endif
|
||||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm/alien.o \
|
||||
vm/bignum.o \
|
||||
|
@ -128,21 +129,11 @@ solaris-x86-32:
|
|||
solaris-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
|
||||
|
||||
freetype6.dll:
|
||||
wget $(DLL_PATH)/freetype6.dll
|
||||
chmod 755 freetype6.dll
|
||||
|
||||
zlib1.dll:
|
||||
wget $(DLL_PATH)/zlib1.dll
|
||||
chmod 755 zlib1.dll
|
||||
|
||||
windows-dlls: freetype6.dll zlib1.dll
|
||||
|
||||
winnt-x86-32: windows-dlls
|
||||
winnt-x86-32:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
|
||||
winnt-x86-64: windows-dlls
|
||||
winnt-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
|
||||
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
|
||||
|
||||
|
@ -159,7 +150,7 @@ macosx.app: factor
|
|||
-change libfactor.dylib \
|
||||
@executable_path/../Frameworks/libfactor.dylib \
|
||||
Factor.app/Contents/MacOS/factor
|
||||
|
||||
|
||||
factor: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays alien.c-types alien.structs
|
||||
sequences math kernel namespaces make libc cpu.architecture ;
|
||||
sequences math kernel namespaces fry libc cpu.architecture ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
@ -10,7 +10,7 @@ M: array c-type ;
|
|||
|
||||
M: array c-type-class drop object ;
|
||||
|
||||
M: array heap-size unclip heap-size [ * ] reduce ;
|
||||
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
|
||||
|
||||
M: array c-type-align first c-type-align ;
|
||||
|
||||
|
@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
M: array stack-size drop "void*" stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot drop f ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
M: value-type c-type-reg-class drop int-regs ;
|
||||
|
||||
M: value-type c-type-boxer-quot drop f ;
|
||||
|
||||
M: value-type c-type-unboxer-quot drop f ;
|
||||
|
||||
M: value-type c-type-getter
|
||||
drop [ swap <displaced-alien> ] ;
|
||||
|
||||
M: value-type c-type-setter ( type -- quot )
|
||||
[
|
||||
dup c-type-getter % \ swap , heap-size , \ memcpy ,
|
||||
] [ ] make ;
|
||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
|
|
@ -178,6 +178,8 @@ $nl
|
|||
{ { $snippet "ulonglong" } { } }
|
||||
{ { $snippet "float" } { } }
|
||||
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
||||
{ { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
|
||||
{ { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
|
||||
}
|
||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
|
||||
$nl
|
||||
|
|
|
@ -201,13 +201,13 @@ M: byte-array byte-length length ;
|
|||
1 swap malloc-array ; inline
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
dup length [ nip malloc dup ] 2keep memcpy ;
|
||||
dup byte-length [ nip malloc dup ] 2keep memcpy ;
|
||||
|
||||
: memory>byte-array ( alien len -- byte-array )
|
||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup length memcpy ;
|
||||
swap dup byte-length memcpy ;
|
||||
|
||||
: array-accessor ( type quot -- def )
|
||||
[
|
||||
|
@ -263,7 +263,7 @@ M: long-long-type box-return ( type -- )
|
|||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents dup malloc-byte-array swap length ;
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
: if-void ( type true false -- )
|
||||
pick "void" = [ drop nip call ] [ nip call ] if ; inline
|
||||
|
@ -283,9 +283,10 @@ M: long-long-type box-return ( type -- )
|
|||
<c-type>
|
||||
c-ptr >>class
|
||||
[ alien-cell ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
[ >c-ptr ] >>unboxer-quot
|
||||
"box_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
"void*" define-primitive-type
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex kernel alien.c-types alien.syntax
|
||||
namespaces ;
|
||||
IN: alien.complex.tests
|
||||
|
||||
C-STRUCT: complex-holder
|
||||
{ "complex-float" "z" } ;
|
||||
|
||||
: <complex-holder> ( z -- alien )
|
||||
"complex-holder" <c-object>
|
||||
[ set-complex-holder-z ] keep ;
|
||||
|
||||
[ ] [
|
||||
C{ 1.0 2.0 } <complex-holder> "h" set
|
||||
] unit-test
|
||||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.complex.functor sequences kernel ;
|
||||
IN: alien.complex
|
||||
|
||||
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.complex.functor ;
|
||||
IN: alien.complex.functor.tests
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.structs alien.c-types math math.functions sequences
|
||||
arrays kernel functors vocabs.parser namespaces accessors
|
||||
quotations ;
|
||||
IN: alien.complex.functor
|
||||
|
||||
FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
T-real DEFINES ${T}-real
|
||||
T-imaginary DEFINES ${T}-imaginary
|
||||
set-T-real DEFINES set-${T}-real
|
||||
set-T-imaginary DEFINES set-${T}-imaginary
|
||||
|
||||
>T DEFINES >${T}
|
||||
T> DEFINES ${T}>
|
||||
|
||||
WHERE
|
||||
|
||||
: >T ( z -- alien )
|
||||
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
|
||||
|
||||
: T> ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T in get
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
|
||||
T c-type
|
||||
T> 1quotation >>boxer-quot
|
||||
>T 1quotation >>unboxer-quot
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
|
@ -0,0 +1 @@
|
|||
Implementation details for C99 complex float and complex double types
|
|
@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry
|
|||
alien.c-types alien.structs.fields cpu.architecture math.order ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type size align fields ;
|
||||
TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
|
@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ;
|
|||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
|
||||
|
||||
|
@ -40,7 +44,10 @@ M: struct-type stack-size
|
|||
|
||||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type boa
|
||||
struct-type new
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
swap typedef ;
|
||||
|
||||
: make-fields ( name vocab fields -- fields )
|
||||
|
|
|
@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global
|
|||
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
|
||||
over 0 = [ 3drop ] [
|
||||
[ <direct-void*-array> ] dip
|
||||
[ each ] [ drop underlying>> (free) ] 2bi
|
||||
[ each ] [ drop (free) ] 2bi
|
||||
] if ; inline
|
||||
|
||||
: register-objc-methods ( class -- )
|
||||
|
|
|
@ -68,7 +68,7 @@ PRIVATE>
|
|||
NSOpenGLPFASamples , 8 ,
|
||||
] when
|
||||
0 ,
|
||||
] int-array{ } make underlying>>
|
||||
] int-array{ } make
|
||||
-> initWithAttributes:
|
||||
-> autorelease ;
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test colors.constants colors ;
|
||||
IN: colors.constants.tests
|
||||
|
||||
[ t ] [ COLOR: light-green rgba? ] unit-test
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math math.parser memoize
|
||||
io.encodings.ascii io.files lexer parser
|
||||
colors sequences splitting combinators.smart ascii ;
|
||||
IN: colors.constants
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-color ( line -- name color )
|
||||
[
|
||||
[ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
|
||||
[ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
|
||||
] input<sequence ;
|
||||
|
||||
: parse-rgb.txt ( lines -- assoc )
|
||||
[ "!" head? not ] filter
|
||||
[ 11 cut [ " \t" split harvest ] dip suffix ] map
|
||||
[ parse-color ] H{ } map>assoc ;
|
||||
|
||||
MEMO: rgb.txt ( -- assoc )
|
||||
"resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: no-such-color name ;
|
||||
|
||||
: named-color ( name -- rgb )
|
||||
dup rgb.txt at [ ] [ no-such-color ] ?if ;
|
||||
|
||||
: COLOR: scan named-color parsed ; parsing
|
|
@ -0,0 +1,753 @@
|
|||
! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $
|
||||
255 250 250 snow
|
||||
248 248 255 ghost white
|
||||
248 248 255 GhostWhite
|
||||
245 245 245 white smoke
|
||||
245 245 245 WhiteSmoke
|
||||
220 220 220 gainsboro
|
||||
255 250 240 floral white
|
||||
255 250 240 FloralWhite
|
||||
253 245 230 old lace
|
||||
253 245 230 OldLace
|
||||
250 240 230 linen
|
||||
250 235 215 antique white
|
||||
250 235 215 AntiqueWhite
|
||||
255 239 213 papaya whip
|
||||
255 239 213 PapayaWhip
|
||||
255 235 205 blanched almond
|
||||
255 235 205 BlanchedAlmond
|
||||
255 228 196 bisque
|
||||
255 218 185 peach puff
|
||||
255 218 185 PeachPuff
|
||||
255 222 173 navajo white
|
||||
255 222 173 NavajoWhite
|
||||
255 228 181 moccasin
|
||||
255 248 220 cornsilk
|
||||
255 255 240 ivory
|
||||
255 250 205 lemon chiffon
|
||||
255 250 205 LemonChiffon
|
||||
255 245 238 seashell
|
||||
240 255 240 honeydew
|
||||
245 255 250 mint cream
|
||||
245 255 250 MintCream
|
||||
240 255 255 azure
|
||||
240 248 255 alice blue
|
||||
240 248 255 AliceBlue
|
||||
230 230 250 lavender
|
||||
255 240 245 lavender blush
|
||||
255 240 245 LavenderBlush
|
||||
255 228 225 misty rose
|
||||
255 228 225 MistyRose
|
||||
255 255 255 white
|
||||
0 0 0 black
|
||||
47 79 79 dark slate gray
|
||||
47 79 79 DarkSlateGray
|
||||
47 79 79 dark slate grey
|
||||
47 79 79 DarkSlateGrey
|
||||
105 105 105 dim gray
|
||||
105 105 105 DimGray
|
||||
105 105 105 dim grey
|
||||
105 105 105 DimGrey
|
||||
112 128 144 slate gray
|
||||
112 128 144 SlateGray
|
||||
112 128 144 slate grey
|
||||
112 128 144 SlateGrey
|
||||
119 136 153 light slate gray
|
||||
119 136 153 LightSlateGray
|
||||
119 136 153 light slate grey
|
||||
119 136 153 LightSlateGrey
|
||||
190 190 190 gray
|
||||
190 190 190 grey
|
||||
211 211 211 light grey
|
||||
211 211 211 LightGrey
|
||||
211 211 211 light gray
|
||||
211 211 211 LightGray
|
||||
25 25 112 midnight blue
|
||||
25 25 112 MidnightBlue
|
||||
0 0 128 navy
|
||||
0 0 128 navy blue
|
||||
0 0 128 NavyBlue
|
||||
100 149 237 cornflower blue
|
||||
100 149 237 CornflowerBlue
|
||||
72 61 139 dark slate blue
|
||||
72 61 139 DarkSlateBlue
|
||||
106 90 205 slate blue
|
||||
106 90 205 SlateBlue
|
||||
123 104 238 medium slate blue
|
||||
123 104 238 MediumSlateBlue
|
||||
132 112 255 light slate blue
|
||||
132 112 255 LightSlateBlue
|
||||
0 0 205 medium blue
|
||||
0 0 205 MediumBlue
|
||||
65 105 225 royal blue
|
||||
65 105 225 RoyalBlue
|
||||
0 0 255 blue
|
||||
30 144 255 dodger blue
|
||||
30 144 255 DodgerBlue
|
||||
0 191 255 deep sky blue
|
||||
0 191 255 DeepSkyBlue
|
||||
135 206 235 sky blue
|
||||
135 206 235 SkyBlue
|
||||
135 206 250 light sky blue
|
||||
135 206 250 LightSkyBlue
|
||||
70 130 180 steel blue
|
||||
70 130 180 SteelBlue
|
||||
176 196 222 light steel blue
|
||||
176 196 222 LightSteelBlue
|
||||
173 216 230 light blue
|
||||
173 216 230 LightBlue
|
||||
176 224 230 powder blue
|
||||
176 224 230 PowderBlue
|
||||
175 238 238 pale turquoise
|
||||
175 238 238 PaleTurquoise
|
||||
0 206 209 dark turquoise
|
||||
0 206 209 DarkTurquoise
|
||||
72 209 204 medium turquoise
|
||||
72 209 204 MediumTurquoise
|
||||
64 224 208 turquoise
|
||||
0 255 255 cyan
|
||||
224 255 255 light cyan
|
||||
224 255 255 LightCyan
|
||||
95 158 160 cadet blue
|
||||
95 158 160 CadetBlue
|
||||
102 205 170 medium aquamarine
|
||||
102 205 170 MediumAquamarine
|
||||
127 255 212 aquamarine
|
||||
0 100 0 dark green
|
||||
0 100 0 DarkGreen
|
||||
85 107 47 dark olive green
|
||||
85 107 47 DarkOliveGreen
|
||||
143 188 143 dark sea green
|
||||
143 188 143 DarkSeaGreen
|
||||
46 139 87 sea green
|
||||
46 139 87 SeaGreen
|
||||
60 179 113 medium sea green
|
||||
60 179 113 MediumSeaGreen
|
||||
32 178 170 light sea green
|
||||
32 178 170 LightSeaGreen
|
||||
152 251 152 pale green
|
||||
152 251 152 PaleGreen
|
||||
0 255 127 spring green
|
||||
0 255 127 SpringGreen
|
||||
124 252 0 lawn green
|
||||
124 252 0 LawnGreen
|
||||
0 255 0 green
|
||||
127 255 0 chartreuse
|
||||
0 250 154 medium spring green
|
||||
0 250 154 MediumSpringGreen
|
||||
173 255 47 green yellow
|
||||
173 255 47 GreenYellow
|
||||
50 205 50 lime green
|
||||
50 205 50 LimeGreen
|
||||
154 205 50 yellow green
|
||||
154 205 50 YellowGreen
|
||||
34 139 34 forest green
|
||||
34 139 34 ForestGreen
|
||||
107 142 35 olive drab
|
||||
107 142 35 OliveDrab
|
||||
189 183 107 dark khaki
|
||||
189 183 107 DarkKhaki
|
||||
240 230 140 khaki
|
||||
238 232 170 pale goldenrod
|
||||
238 232 170 PaleGoldenrod
|
||||
250 250 210 light goldenrod yellow
|
||||
250 250 210 LightGoldenrodYellow
|
||||
255 255 224 light yellow
|
||||
255 255 224 LightYellow
|
||||
255 255 0 yellow
|
||||
255 215 0 gold
|
||||
238 221 130 light goldenrod
|
||||
238 221 130 LightGoldenrod
|
||||
218 165 32 goldenrod
|
||||
184 134 11 dark goldenrod
|
||||
184 134 11 DarkGoldenrod
|
||||
188 143 143 rosy brown
|
||||
188 143 143 RosyBrown
|
||||
205 92 92 indian red
|
||||
205 92 92 IndianRed
|
||||
139 69 19 saddle brown
|
||||
139 69 19 SaddleBrown
|
||||
160 82 45 sienna
|
||||
205 133 63 peru
|
||||
222 184 135 burlywood
|
||||
245 245 220 beige
|
||||
245 222 179 wheat
|
||||
244 164 96 sandy brown
|
||||
244 164 96 SandyBrown
|
||||
210 180 140 tan
|
||||
210 105 30 chocolate
|
||||
178 34 34 firebrick
|
||||
165 42 42 brown
|
||||
233 150 122 dark salmon
|
||||
233 150 122 DarkSalmon
|
||||
250 128 114 salmon
|
||||
255 160 122 light salmon
|
||||
255 160 122 LightSalmon
|
||||
255 165 0 orange
|
||||
255 140 0 dark orange
|
||||
255 140 0 DarkOrange
|
||||
255 127 80 coral
|
||||
240 128 128 light coral
|
||||
240 128 128 LightCoral
|
||||
255 99 71 tomato
|
||||
255 69 0 orange red
|
||||
255 69 0 OrangeRed
|
||||
255 0 0 red
|
||||
255 105 180 hot pink
|
||||
255 105 180 HotPink
|
||||
255 20 147 deep pink
|
||||
255 20 147 DeepPink
|
||||
255 192 203 pink
|
||||
255 182 193 light pink
|
||||
255 182 193 LightPink
|
||||
219 112 147 pale violet red
|
||||
219 112 147 PaleVioletRed
|
||||
176 48 96 maroon
|
||||
199 21 133 medium violet red
|
||||
199 21 133 MediumVioletRed
|
||||
208 32 144 violet red
|
||||
208 32 144 VioletRed
|
||||
255 0 255 magenta
|
||||
238 130 238 violet
|
||||
221 160 221 plum
|
||||
218 112 214 orchid
|
||||
186 85 211 medium orchid
|
||||
186 85 211 MediumOrchid
|
||||
153 50 204 dark orchid
|
||||
153 50 204 DarkOrchid
|
||||
148 0 211 dark violet
|
||||
148 0 211 DarkViolet
|
||||
138 43 226 blue violet
|
||||
138 43 226 BlueViolet
|
||||
160 32 240 purple
|
||||
147 112 219 medium purple
|
||||
147 112 219 MediumPurple
|
||||
216 191 216 thistle
|
||||
255 250 250 snow1
|
||||
238 233 233 snow2
|
||||
205 201 201 snow3
|
||||
139 137 137 snow4
|
||||
255 245 238 seashell1
|
||||
238 229 222 seashell2
|
||||
205 197 191 seashell3
|
||||
139 134 130 seashell4
|
||||
255 239 219 AntiqueWhite1
|
||||
238 223 204 AntiqueWhite2
|
||||
205 192 176 AntiqueWhite3
|
||||
139 131 120 AntiqueWhite4
|
||||
255 228 196 bisque1
|
||||
238 213 183 bisque2
|
||||
205 183 158 bisque3
|
||||
139 125 107 bisque4
|
||||
255 218 185 PeachPuff1
|
||||
238 203 173 PeachPuff2
|
||||
205 175 149 PeachPuff3
|
||||
139 119 101 PeachPuff4
|
||||
255 222 173 NavajoWhite1
|
||||
238 207 161 NavajoWhite2
|
||||
205 179 139 NavajoWhite3
|
||||
139 121 94 NavajoWhite4
|
||||
255 250 205 LemonChiffon1
|
||||
238 233 191 LemonChiffon2
|
||||
205 201 165 LemonChiffon3
|
||||
139 137 112 LemonChiffon4
|
||||
255 248 220 cornsilk1
|
||||
238 232 205 cornsilk2
|
||||
205 200 177 cornsilk3
|
||||
139 136 120 cornsilk4
|
||||
255 255 240 ivory1
|
||||
238 238 224 ivory2
|
||||
205 205 193 ivory3
|
||||
139 139 131 ivory4
|
||||
240 255 240 honeydew1
|
||||
224 238 224 honeydew2
|
||||
193 205 193 honeydew3
|
||||
131 139 131 honeydew4
|
||||
255 240 245 LavenderBlush1
|
||||
238 224 229 LavenderBlush2
|
||||
205 193 197 LavenderBlush3
|
||||
139 131 134 LavenderBlush4
|
||||
255 228 225 MistyRose1
|
||||
238 213 210 MistyRose2
|
||||
205 183 181 MistyRose3
|
||||
139 125 123 MistyRose4
|
||||
240 255 255 azure1
|
||||
224 238 238 azure2
|
||||
193 205 205 azure3
|
||||
131 139 139 azure4
|
||||
131 111 255 SlateBlue1
|
||||
122 103 238 SlateBlue2
|
||||
105 89 205 SlateBlue3
|
||||
71 60 139 SlateBlue4
|
||||
72 118 255 RoyalBlue1
|
||||
67 110 238 RoyalBlue2
|
||||
58 95 205 RoyalBlue3
|
||||
39 64 139 RoyalBlue4
|
||||
0 0 255 blue1
|
||||
0 0 238 blue2
|
||||
0 0 205 blue3
|
||||
0 0 139 blue4
|
||||
30 144 255 DodgerBlue1
|
||||
28 134 238 DodgerBlue2
|
||||
24 116 205 DodgerBlue3
|
||||
16 78 139 DodgerBlue4
|
||||
99 184 255 SteelBlue1
|
||||
92 172 238 SteelBlue2
|
||||
79 148 205 SteelBlue3
|
||||
54 100 139 SteelBlue4
|
||||
0 191 255 DeepSkyBlue1
|
||||
0 178 238 DeepSkyBlue2
|
||||
0 154 205 DeepSkyBlue3
|
||||
0 104 139 DeepSkyBlue4
|
||||
135 206 255 SkyBlue1
|
||||
126 192 238 SkyBlue2
|
||||
108 166 205 SkyBlue3
|
||||
74 112 139 SkyBlue4
|
||||
176 226 255 LightSkyBlue1
|
||||
164 211 238 LightSkyBlue2
|
||||
141 182 205 LightSkyBlue3
|
||||
96 123 139 LightSkyBlue4
|
||||
198 226 255 SlateGray1
|
||||
185 211 238 SlateGray2
|
||||
159 182 205 SlateGray3
|
||||
108 123 139 SlateGray4
|
||||
202 225 255 LightSteelBlue1
|
||||
188 210 238 LightSteelBlue2
|
||||
162 181 205 LightSteelBlue3
|
||||
110 123 139 LightSteelBlue4
|
||||
191 239 255 LightBlue1
|
||||
178 223 238 LightBlue2
|
||||
154 192 205 LightBlue3
|
||||
104 131 139 LightBlue4
|
||||
224 255 255 LightCyan1
|
||||
209 238 238 LightCyan2
|
||||
180 205 205 LightCyan3
|
||||
122 139 139 LightCyan4
|
||||
187 255 255 PaleTurquoise1
|
||||
174 238 238 PaleTurquoise2
|
||||
150 205 205 PaleTurquoise3
|
||||
102 139 139 PaleTurquoise4
|
||||
152 245 255 CadetBlue1
|
||||
142 229 238 CadetBlue2
|
||||
122 197 205 CadetBlue3
|
||||
83 134 139 CadetBlue4
|
||||
0 245 255 turquoise1
|
||||
0 229 238 turquoise2
|
||||
0 197 205 turquoise3
|
||||
0 134 139 turquoise4
|
||||
0 255 255 cyan1
|
||||
0 238 238 cyan2
|
||||
0 205 205 cyan3
|
||||
0 139 139 cyan4
|
||||
151 255 255 DarkSlateGray1
|
||||
141 238 238 DarkSlateGray2
|
||||
121 205 205 DarkSlateGray3
|
||||
82 139 139 DarkSlateGray4
|
||||
127 255 212 aquamarine1
|
||||
118 238 198 aquamarine2
|
||||
102 205 170 aquamarine3
|
||||
69 139 116 aquamarine4
|
||||
193 255 193 DarkSeaGreen1
|
||||
180 238 180 DarkSeaGreen2
|
||||
155 205 155 DarkSeaGreen3
|
||||
105 139 105 DarkSeaGreen4
|
||||
84 255 159 SeaGreen1
|
||||
78 238 148 SeaGreen2
|
||||
67 205 128 SeaGreen3
|
||||
46 139 87 SeaGreen4
|
||||
154 255 154 PaleGreen1
|
||||
144 238 144 PaleGreen2
|
||||
124 205 124 PaleGreen3
|
||||
84 139 84 PaleGreen4
|
||||
0 255 127 SpringGreen1
|
||||
0 238 118 SpringGreen2
|
||||
0 205 102 SpringGreen3
|
||||
0 139 69 SpringGreen4
|
||||
0 255 0 green1
|
||||
0 238 0 green2
|
||||
0 205 0 green3
|
||||
0 139 0 green4
|
||||
127 255 0 chartreuse1
|
||||
118 238 0 chartreuse2
|
||||
102 205 0 chartreuse3
|
||||
69 139 0 chartreuse4
|
||||
192 255 62 OliveDrab1
|
||||
179 238 58 OliveDrab2
|
||||
154 205 50 OliveDrab3
|
||||
105 139 34 OliveDrab4
|
||||
202 255 112 DarkOliveGreen1
|
||||
188 238 104 DarkOliveGreen2
|
||||
162 205 90 DarkOliveGreen3
|
||||
110 139 61 DarkOliveGreen4
|
||||
255 246 143 khaki1
|
||||
238 230 133 khaki2
|
||||
205 198 115 khaki3
|
||||
139 134 78 khaki4
|
||||
255 236 139 LightGoldenrod1
|
||||
238 220 130 LightGoldenrod2
|
||||
205 190 112 LightGoldenrod3
|
||||
139 129 76 LightGoldenrod4
|
||||
255 255 224 LightYellow1
|
||||
238 238 209 LightYellow2
|
||||
205 205 180 LightYellow3
|
||||
139 139 122 LightYellow4
|
||||
255 255 0 yellow1
|
||||
238 238 0 yellow2
|
||||
205 205 0 yellow3
|
||||
139 139 0 yellow4
|
||||
255 215 0 gold1
|
||||
238 201 0 gold2
|
||||
205 173 0 gold3
|
||||
139 117 0 gold4
|
||||
255 193 37 goldenrod1
|
||||
238 180 34 goldenrod2
|
||||
205 155 29 goldenrod3
|
||||
139 105 20 goldenrod4
|
||||
255 185 15 DarkGoldenrod1
|
||||
238 173 14 DarkGoldenrod2
|
||||
205 149 12 DarkGoldenrod3
|
||||
139 101 8 DarkGoldenrod4
|
||||
255 193 193 RosyBrown1
|
||||
238 180 180 RosyBrown2
|
||||
205 155 155 RosyBrown3
|
||||
139 105 105 RosyBrown4
|
||||
255 106 106 IndianRed1
|
||||
238 99 99 IndianRed2
|
||||
205 85 85 IndianRed3
|
||||
139 58 58 IndianRed4
|
||||
255 130 71 sienna1
|
||||
238 121 66 sienna2
|
||||
205 104 57 sienna3
|
||||
139 71 38 sienna4
|
||||
255 211 155 burlywood1
|
||||
238 197 145 burlywood2
|
||||
205 170 125 burlywood3
|
||||
139 115 85 burlywood4
|
||||
255 231 186 wheat1
|
||||
238 216 174 wheat2
|
||||
205 186 150 wheat3
|
||||
139 126 102 wheat4
|
||||
255 165 79 tan1
|
||||
238 154 73 tan2
|
||||
205 133 63 tan3
|
||||
139 90 43 tan4
|
||||
255 127 36 chocolate1
|
||||
238 118 33 chocolate2
|
||||
205 102 29 chocolate3
|
||||
139 69 19 chocolate4
|
||||
255 48 48 firebrick1
|
||||
238 44 44 firebrick2
|
||||
205 38 38 firebrick3
|
||||
139 26 26 firebrick4
|
||||
255 64 64 brown1
|
||||
238 59 59 brown2
|
||||
205 51 51 brown3
|
||||
139 35 35 brown4
|
||||
255 140 105 salmon1
|
||||
238 130 98 salmon2
|
||||
205 112 84 salmon3
|
||||
139 76 57 salmon4
|
||||
255 160 122 LightSalmon1
|
||||
238 149 114 LightSalmon2
|
||||
205 129 98 LightSalmon3
|
||||
139 87 66 LightSalmon4
|
||||
255 165 0 orange1
|
||||
238 154 0 orange2
|
||||
205 133 0 orange3
|
||||
139 90 0 orange4
|
||||
255 127 0 DarkOrange1
|
||||
238 118 0 DarkOrange2
|
||||
205 102 0 DarkOrange3
|
||||
139 69 0 DarkOrange4
|
||||
255 114 86 coral1
|
||||
238 106 80 coral2
|
||||
205 91 69 coral3
|
||||
139 62 47 coral4
|
||||
255 99 71 tomato1
|
||||
238 92 66 tomato2
|
||||
205 79 57 tomato3
|
||||
139 54 38 tomato4
|
||||
255 69 0 OrangeRed1
|
||||
238 64 0 OrangeRed2
|
||||
205 55 0 OrangeRed3
|
||||
139 37 0 OrangeRed4
|
||||
255 0 0 red1
|
||||
238 0 0 red2
|
||||
205 0 0 red3
|
||||
139 0 0 red4
|
||||
255 20 147 DeepPink1
|
||||
238 18 137 DeepPink2
|
||||
205 16 118 DeepPink3
|
||||
139 10 80 DeepPink4
|
||||
255 110 180 HotPink1
|
||||
238 106 167 HotPink2
|
||||
205 96 144 HotPink3
|
||||
139 58 98 HotPink4
|
||||
255 181 197 pink1
|
||||
238 169 184 pink2
|
||||
205 145 158 pink3
|
||||
139 99 108 pink4
|
||||
255 174 185 LightPink1
|
||||
238 162 173 LightPink2
|
||||
205 140 149 LightPink3
|
||||
139 95 101 LightPink4
|
||||
255 130 171 PaleVioletRed1
|
||||
238 121 159 PaleVioletRed2
|
||||
205 104 137 PaleVioletRed3
|
||||
139 71 93 PaleVioletRed4
|
||||
255 52 179 maroon1
|
||||
238 48 167 maroon2
|
||||
205 41 144 maroon3
|
||||
139 28 98 maroon4
|
||||
255 62 150 VioletRed1
|
||||
238 58 140 VioletRed2
|
||||
205 50 120 VioletRed3
|
||||
139 34 82 VioletRed4
|
||||
255 0 255 magenta1
|
||||
238 0 238 magenta2
|
||||
205 0 205 magenta3
|
||||
139 0 139 magenta4
|
||||
255 131 250 orchid1
|
||||
238 122 233 orchid2
|
||||
205 105 201 orchid3
|
||||
139 71 137 orchid4
|
||||
255 187 255 plum1
|
||||
238 174 238 plum2
|
||||
205 150 205 plum3
|
||||
139 102 139 plum4
|
||||
224 102 255 MediumOrchid1
|
||||
209 95 238 MediumOrchid2
|
||||
180 82 205 MediumOrchid3
|
||||
122 55 139 MediumOrchid4
|
||||
191 62 255 DarkOrchid1
|
||||
178 58 238 DarkOrchid2
|
||||
154 50 205 DarkOrchid3
|
||||
104 34 139 DarkOrchid4
|
||||
155 48 255 purple1
|
||||
145 44 238 purple2
|
||||
125 38 205 purple3
|
||||
85 26 139 purple4
|
||||
171 130 255 MediumPurple1
|
||||
159 121 238 MediumPurple2
|
||||
137 104 205 MediumPurple3
|
||||
93 71 139 MediumPurple4
|
||||
255 225 255 thistle1
|
||||
238 210 238 thistle2
|
||||
205 181 205 thistle3
|
||||
139 123 139 thistle4
|
||||
0 0 0 gray0
|
||||
0 0 0 grey0
|
||||
3 3 3 gray1
|
||||
3 3 3 grey1
|
||||
5 5 5 gray2
|
||||
5 5 5 grey2
|
||||
8 8 8 gray3
|
||||
8 8 8 grey3
|
||||
10 10 10 gray4
|
||||
10 10 10 grey4
|
||||
13 13 13 gray5
|
||||
13 13 13 grey5
|
||||
15 15 15 gray6
|
||||
15 15 15 grey6
|
||||
18 18 18 gray7
|
||||
18 18 18 grey7
|
||||
20 20 20 gray8
|
||||
20 20 20 grey8
|
||||
23 23 23 gray9
|
||||
23 23 23 grey9
|
||||
26 26 26 gray10
|
||||
26 26 26 grey10
|
||||
28 28 28 gray11
|
||||
28 28 28 grey11
|
||||
31 31 31 gray12
|
||||
31 31 31 grey12
|
||||
33 33 33 gray13
|
||||
33 33 33 grey13
|
||||
36 36 36 gray14
|
||||
36 36 36 grey14
|
||||
38 38 38 gray15
|
||||
38 38 38 grey15
|
||||
41 41 41 gray16
|
||||
41 41 41 grey16
|
||||
43 43 43 gray17
|
||||
43 43 43 grey17
|
||||
46 46 46 gray18
|
||||
46 46 46 grey18
|
||||
48 48 48 gray19
|
||||
48 48 48 grey19
|
||||
51 51 51 gray20
|
||||
51 51 51 grey20
|
||||
54 54 54 gray21
|
||||
54 54 54 grey21
|
||||
56 56 56 gray22
|
||||
56 56 56 grey22
|
||||
59 59 59 gray23
|
||||
59 59 59 grey23
|
||||
61 61 61 gray24
|
||||
61 61 61 grey24
|
||||
64 64 64 gray25
|
||||
64 64 64 grey25
|
||||
66 66 66 gray26
|
||||
66 66 66 grey26
|
||||
69 69 69 gray27
|
||||
69 69 69 grey27
|
||||
71 71 71 gray28
|
||||
71 71 71 grey28
|
||||
74 74 74 gray29
|
||||
74 74 74 grey29
|
||||
77 77 77 gray30
|
||||
77 77 77 grey30
|
||||
79 79 79 gray31
|
||||
79 79 79 grey31
|
||||
82 82 82 gray32
|
||||
82 82 82 grey32
|
||||
84 84 84 gray33
|
||||
84 84 84 grey33
|
||||
87 87 87 gray34
|
||||
87 87 87 grey34
|
||||
89 89 89 gray35
|
||||
89 89 89 grey35
|
||||
92 92 92 gray36
|
||||
92 92 92 grey36
|
||||
94 94 94 gray37
|
||||
94 94 94 grey37
|
||||
97 97 97 gray38
|
||||
97 97 97 grey38
|
||||
99 99 99 gray39
|
||||
99 99 99 grey39
|
||||
102 102 102 gray40
|
||||
102 102 102 grey40
|
||||
105 105 105 gray41
|
||||
105 105 105 grey41
|
||||
107 107 107 gray42
|
||||
107 107 107 grey42
|
||||
110 110 110 gray43
|
||||
110 110 110 grey43
|
||||
112 112 112 gray44
|
||||
112 112 112 grey44
|
||||
115 115 115 gray45
|
||||
115 115 115 grey45
|
||||
117 117 117 gray46
|
||||
117 117 117 grey46
|
||||
120 120 120 gray47
|
||||
120 120 120 grey47
|
||||
122 122 122 gray48
|
||||
122 122 122 grey48
|
||||
125 125 125 gray49
|
||||
125 125 125 grey49
|
||||
127 127 127 gray50
|
||||
127 127 127 grey50
|
||||
130 130 130 gray51
|
||||
130 130 130 grey51
|
||||
133 133 133 gray52
|
||||
133 133 133 grey52
|
||||
135 135 135 gray53
|
||||
135 135 135 grey53
|
||||
138 138 138 gray54
|
||||
138 138 138 grey54
|
||||
140 140 140 gray55
|
||||
140 140 140 grey55
|
||||
143 143 143 gray56
|
||||
143 143 143 grey56
|
||||
145 145 145 gray57
|
||||
145 145 145 grey57
|
||||
148 148 148 gray58
|
||||
148 148 148 grey58
|
||||
150 150 150 gray59
|
||||
150 150 150 grey59
|
||||
153 153 153 gray60
|
||||
153 153 153 grey60
|
||||
156 156 156 gray61
|
||||
156 156 156 grey61
|
||||
158 158 158 gray62
|
||||
158 158 158 grey62
|
||||
161 161 161 gray63
|
||||
161 161 161 grey63
|
||||
163 163 163 gray64
|
||||
163 163 163 grey64
|
||||
166 166 166 gray65
|
||||
166 166 166 grey65
|
||||
168 168 168 gray66
|
||||
168 168 168 grey66
|
||||
171 171 171 gray67
|
||||
171 171 171 grey67
|
||||
173 173 173 gray68
|
||||
173 173 173 grey68
|
||||
176 176 176 gray69
|
||||
176 176 176 grey69
|
||||
179 179 179 gray70
|
||||
179 179 179 grey70
|
||||
181 181 181 gray71
|
||||
181 181 181 grey71
|
||||
184 184 184 gray72
|
||||
184 184 184 grey72
|
||||
186 186 186 gray73
|
||||
186 186 186 grey73
|
||||
189 189 189 gray74
|
||||
189 189 189 grey74
|
||||
191 191 191 gray75
|
||||
191 191 191 grey75
|
||||
194 194 194 gray76
|
||||
194 194 194 grey76
|
||||
196 196 196 gray77
|
||||
196 196 196 grey77
|
||||
199 199 199 gray78
|
||||
199 199 199 grey78
|
||||
201 201 201 gray79
|
||||
201 201 201 grey79
|
||||
204 204 204 gray80
|
||||
204 204 204 grey80
|
||||
207 207 207 gray81
|
||||
207 207 207 grey81
|
||||
209 209 209 gray82
|
||||
209 209 209 grey82
|
||||
212 212 212 gray83
|
||||
212 212 212 grey83
|
||||
214 214 214 gray84
|
||||
214 214 214 grey84
|
||||
217 217 217 gray85
|
||||
217 217 217 grey85
|
||||
219 219 219 gray86
|
||||
219 219 219 grey86
|
||||
222 222 222 gray87
|
||||
222 222 222 grey87
|
||||
224 224 224 gray88
|
||||
224 224 224 grey88
|
||||
227 227 227 gray89
|
||||
227 227 227 grey89
|
||||
229 229 229 gray90
|
||||
229 229 229 grey90
|
||||
232 232 232 gray91
|
||||
232 232 232 grey91
|
||||
235 235 235 gray92
|
||||
235 235 235 grey92
|
||||
237 237 237 gray93
|
||||
237 237 237 grey93
|
||||
240 240 240 gray94
|
||||
240 240 240 grey94
|
||||
242 242 242 gray95
|
||||
242 242 242 grey95
|
||||
245 245 245 gray96
|
||||
245 245 245 grey96
|
||||
247 247 247 gray97
|
||||
247 247 247 grey97
|
||||
250 250 250 gray98
|
||||
250 250 250 grey98
|
||||
252 252 252 gray99
|
||||
252 252 252 grey99
|
||||
255 255 255 gray100
|
||||
255 255 255 grey100
|
||||
169 169 169 dark grey
|
||||
169 169 169 DarkGrey
|
||||
169 169 169 dark gray
|
||||
169 169 169 DarkGray
|
||||
0 0 139 dark blue
|
||||
0 0 139 DarkBlue
|
||||
0 139 139 dark cyan
|
||||
0 139 139 DarkCyan
|
||||
139 0 139 dark magenta
|
||||
139 0 139 DarkMagenta
|
||||
139 0 0 dark red
|
||||
139 0 0 DarkRed
|
||||
144 238 144 light green
|
||||
144 238 144 LightGreen
|
|
@ -0,0 +1 @@
|
|||
A utility to look up colors in the X11 rgb.txt color database
|
|
@ -37,3 +37,11 @@ IN: combinators.smart.tests
|
|||
[
|
||||
[ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
|
||||
] unit-test
|
||||
|
||||
! Test nesting
|
||||
: nested-smart-combo-test ( -- array )
|
||||
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
|
||||
|
||||
\ nested-smart-combo-test must-infer
|
||||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
|
@ -3,8 +3,8 @@
|
|||
USING: namespaces make math math.order math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays sets libc continuations.private
|
||||
fry cpu.architecture
|
||||
alien.strings alien.arrays alien.complex sets libc
|
||||
continuations.private fry cpu.architecture
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.cfg
|
||||
|
|
|
@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
|
|||
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
|
||||
|
||||
[ 32.0 ] [
|
||||
{ 1.0 2.0 3.0 } >float-array underlying>>
|
||||
{ 4.0 5.0 6.0 } >float-array underlying>>
|
||||
{ 1.0 2.0 3.0 } >float-array
|
||||
{ 4.0 5.0 6.0 } >float-array
|
||||
ffi_test_23
|
||||
] unit-test
|
||||
|
||||
|
@ -558,3 +558,10 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
|
|||
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
|
||||
|
||||
[ ] [ stack-frame-bustage 2drop ] unit-test
|
||||
|
||||
FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ;
|
||||
|
||||
[ C{ 4.0 4.0 } ] [
|
||||
C{ 1.0 2.0 }
|
||||
C{ 1.5 1.0 } ffi_test_45
|
||||
] unit-test
|
|
@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
} case ;
|
||||
|
||||
: param-types ( statement -- seq )
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
|
||||
in-params>> [ type>> type>oid ] uint-array{ } map-as ;
|
||||
|
||||
: malloc-byte-array/length ( byte-array -- alien length )
|
||||
[ malloc-byte-array &free ] [ length ] bi ;
|
||||
|
@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
] 2map flip [
|
||||
f f
|
||||
] [
|
||||
first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
|
||||
first2 [ >void*-array ] [ >uint-array ] bi*
|
||||
] if-empty ;
|
||||
|
||||
: param-formats ( statement -- seq )
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
|
||||
in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
|
||||
|
||||
: do-postgresql-bound-statement ( statement -- res )
|
||||
[
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
|
||||
urls.encoding assocs xml.utilities xml.data ;
|
||||
urls.encoding assocs xml.traversal xml.data ;
|
||||
IN: farkup.tests
|
||||
|
||||
relative-link-prefix off
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators io
|
||||
io.streams.string kernel math namespaces peg peg.ebnf
|
||||
sequences sequences.deep strings xml.entities xml.literals
|
||||
sequences sequences.deep strings xml.entities xml.syntax
|
||||
vectors splitting xmode.code2html urls.encoding xml.data
|
||||
xml.writer ;
|
||||
IN: farkup
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
IN: functors.tests
|
||||
USING: functors tools.test math words kernel ;
|
||||
USING: functors tools.test math words kernel multiline parser
|
||||
io.streams.string generic ;
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: define-box ( T -- )
|
||||
|
||||
B DEFINES ${T}-box
|
||||
B DEFINES-CLASS ${T}-box
|
||||
<B> DEFINES <${B}>
|
||||
|
||||
WHERE
|
||||
|
@ -62,4 +63,48 @@ WHERE
|
|||
|
||||
>>
|
||||
|
||||
[ 4 ] [ 1 3 blah ] unit-test
|
||||
[ 4 ] [ 1 3 blah ] unit-test
|
||||
|
||||
GENERIC: some-generic ( a -- b )
|
||||
|
||||
! Does replacing an ordinary word with a functor-generated one work?
|
||||
[ [ ] ] [
|
||||
<" IN: functors.tests
|
||||
|
||||
TUPLE: some-tuple ;
|
||||
: some-word ( -- ) ;
|
||||
M: some-tuple some-generic ;
|
||||
"> <string-reader> "functors-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
: test-redefinition ( -- )
|
||||
[ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
|
||||
[ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
|
||||
[ t ] [
|
||||
"some-tuple" "functors.tests" lookup
|
||||
"some-generic" "functors.tests" lookup method >boolean
|
||||
] unit-test ;
|
||||
|
||||
test-redefinition
|
||||
|
||||
FUNCTOR: redefine-test ( W -- )
|
||||
|
||||
W-word DEFINES ${W}-word
|
||||
W-tuple DEFINES-CLASS ${W}-tuple
|
||||
W-generic IS ${W}-generic
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: W-tuple ;
|
||||
: W-word ( -- ) ;
|
||||
M: W-tuple W-generic ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
[ [ ] ] [
|
||||
<" IN: functors.tests
|
||||
<< "some" redefine-test >>
|
||||
"> <string-reader> "functors-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
test-redefinition
|
|
@ -3,8 +3,9 @@
|
|||
USING: kernel quotations classes.tuple make combinators generic
|
||||
words interpolate namespaces sequences io.streams.string fry
|
||||
classes.mixin effects lexer parser classes.tuple.parser
|
||||
effects.parser locals.types locals.parser
|
||||
locals.rewrite.closures vocabs.parser arrays accessors ;
|
||||
effects.parser locals.types locals.parser generic.parser
|
||||
locals.rewrite.closures vocabs.parser classes.parser
|
||||
arrays accessors ;
|
||||
IN: functors
|
||||
|
||||
! This is a hack
|
||||
|
@ -29,7 +30,7 @@ M: object >fake-quotations ;
|
|||
GENERIC: fake-quotations> ( fake -- quot )
|
||||
|
||||
M: fake-quotation fake-quotations>
|
||||
seq>> [ fake-quotations> ] map >quotation ;
|
||||
seq>> [ fake-quotations> ] [ ] map-as ;
|
||||
|
||||
M: array fake-quotations> [ fake-quotations> ] map ;
|
||||
|
||||
|
@ -57,7 +58,7 @@ M: object fake-quotations> ;
|
|||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method parsed
|
||||
\ create-method-in parsed
|
||||
parse-definition*
|
||||
DEFINE* ; parsing
|
||||
|
||||
|
@ -96,6 +97,8 @@ PRIVATE>
|
|||
|
||||
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
DEFER: ;FUNCTOR delimiter
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -7,8 +7,8 @@ xml
|
|||
xml.data
|
||||
xml.entities
|
||||
xml.writer
|
||||
xml.utilities
|
||||
xml.literals
|
||||
xml.traversal
|
||||
xml.syntax
|
||||
html.components
|
||||
html.elements
|
||||
html.forms
|
||||
|
|
|
@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel
|
|||
assocs sequences make words accessors arrays help.topics vocabs
|
||||
tools.vocabs tools.vocabs.browser namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
sorting debugger html xml.literals xml.writer ;
|
||||
sorting debugger html xml.syntax xml.writer ;
|
||||
IN: help.html
|
||||
|
||||
: escape-char ( ch -- )
|
||||
|
|
|
@ -100,6 +100,6 @@ $nl
|
|||
{ $subsection farkup }
|
||||
"Creating custom components:"
|
||||
{ $subsection render* }
|
||||
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
|
||||
"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ;
|
||||
|
||||
ABOUT: "html.components"
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes
|
|||
classes.tuple words arrays sequences splitting mirrors
|
||||
hashtables combinators continuations math strings inspector
|
||||
fry locals calendar calendar.format xml.entities xml.data
|
||||
validators urls present xml.writer xml.literals xml
|
||||
validators urls present xml.writer xml.syntax xml
|
||||
xmode.code2html lcs.diff2html farkup io.streams.string
|
||||
html html.streams html.forms ;
|
||||
IN: html.components
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.styles kernel namespaces prettyprint quotations
|
||||
sequences strings words xml.entities compiler.units effects
|
||||
xml.data xml.literals urls math math.parser combinators
|
||||
xml.data urls math math.parser combinators
|
||||
present fry io.streams.string xml.writer html ;
|
||||
IN: html.elements
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors strings namespaces assocs hashtables io
|
||||
mirrors math fry sequences words continuations
|
||||
xml.entities xml.writer xml.literals ;
|
||||
xml.entities xml.writer xml.syntax ;
|
||||
IN: html.forms
|
||||
|
||||
TUPLE: form errors values validation-failed ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel xml.data xml.writer xml.literals urls.encoding ;
|
||||
USING: kernel xml.data xml.writer xml.syntax urls.encoding ;
|
||||
IN: html
|
||||
|
||||
: simple-page ( title head body -- xml )
|
||||
|
@ -21,4 +21,4 @@ IN: html
|
|||
[XML <span class="error"><-></span> XML] ;
|
||||
|
||||
: simple-link ( xml url -- xml' )
|
||||
url-encode swap [XML <a href=<->><-></a> XML] ;
|
||||
url-encode swap [XML <a href=<->><-></a> XML] ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel assocs io io.styles math math.order math.parser
|
||||
sequences strings make words combinators macros xml.literals html fry
|
||||
sequences strings make words combinators macros xml.syntax html fry
|
||||
destructors ;
|
||||
IN: html.streams
|
||||
|
||||
|
|
|
@ -5,7 +5,7 @@ namespaces make classes.tuple assocs splitting words arrays io
|
|||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging continuations
|
||||
xml.data xml.writer xml.literals strings
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
html.elements
|
||||
|
|
|
@ -5,7 +5,7 @@ USING: accessors kernel sequences combinators kernel namespaces
|
|||
classes.tuple assocs splitting words arrays memoize parser lexer
|
||||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors fry math urls
|
||||
multiline xml xml.data xml.writer xml.utilities
|
||||
multiline xml xml.data xml.writer xml.syntax
|
||||
html.components
|
||||
html.templates ;
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel fry io io.encodings.utf8 io.files
|
||||
debugger prettyprint continuations namespaces boxes sequences
|
||||
arrays strings html io.streams.string
|
||||
quotations xml.data xml.writer xml.literals ;
|
||||
quotations xml.data xml.writer xml.syntax ;
|
||||
IN: html.templates
|
||||
|
||||
MIXIN: template
|
||||
|
|
|
@ -299,7 +299,7 @@ test-db [
|
|||
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
|
||||
|
||||
USING: html.components html.forms
|
||||
xml xml.utilities validators
|
||||
xml xml.traversal validators
|
||||
furnace furnace.conversations ;
|
||||
|
||||
SYMBOL: a
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.parser http accessors kernel xml.literals xml.writer
|
||||
USING: math.parser http accessors kernel xml.syntax xml.writer
|
||||
io io.streams.string io.encodings.utf8 ;
|
||||
IN: http.server.responses
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces
|
|||
parser sequences strings assocs hashtables debugger mime.types
|
||||
sorting logging calendar.format accessors splitting io io.files
|
||||
io.files.info io.directories io.pathnames io.encodings.binary
|
||||
fry xml.entities destructors urls html xml.literals
|
||||
fry xml.entities destructors urls html xml.syntax
|
||||
html.templates.fhtml http http.server http.server.responses
|
||||
http.server.redirection xml.writer ;
|
||||
IN: http.server.static
|
||||
|
|
|
@ -71,6 +71,9 @@ C: <nil> nil
|
|||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||
[ ] [ 3 [ _ ] undo ] unit-test
|
||||
|
||||
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
|
||||
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
|
||||
|
||||
[ { 1 } ] [ { 1 2 3 } [ { 2 3 } append ] undo ] unit-test
|
||||
[ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
|
||||
[ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
|
|
@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
|
|||
continuations debugger classes.tuple namespaces make vectors
|
||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||
sequences.private combinators mirrors splitting
|
||||
combinators.short-circuit fry words.symbol ;
|
||||
combinators.short-circuit fry words.symbol generalizations ;
|
||||
RENAME: _ fry => __
|
||||
IN: inverse
|
||||
|
||||
|
@ -163,7 +163,7 @@ ERROR: missing-literal ;
|
|||
\ - [ + ] [ - ] define-math-inverse
|
||||
\ * [ / ] [ / ] define-math-inverse
|
||||
\ / [ * ] [ / ] define-math-inverse
|
||||
\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
|
||||
\ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse
|
||||
|
||||
\ ? 2 [
|
||||
[ assert-literal ] bi@
|
||||
|
@ -199,6 +199,7 @@ DEFER: _
|
|||
\ 2array [ 2 assure-length first2 ] define-inverse
|
||||
\ 3array [ 3 assure-length first3 ] define-inverse
|
||||
\ 4array [ 4 assure-length first4 ] define-inverse
|
||||
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
|
||||
|
||||
\ first [ 1array ] define-inverse
|
||||
\ first2 [ 2array ] define-inverse
|
|
@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
|||
] [ 2drop f ] if ;
|
||||
|
||||
: wait-event ( mx us -- n )
|
||||
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||
[ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi*
|
||||
epoll_wait multiplexer-error ;
|
||||
|
||||
: handle-event ( event mx -- )
|
||||
|
|
|
@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
|||
: wait-kevent ( mx timespec -- n )
|
||||
[
|
||||
[ fd>> f 0 ]
|
||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||
[ events>> dup length ] bi
|
||||
] dip kevent multiplexer-error ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
|
|
|
@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
|
||||
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
|
||||
[ read-fdset/tasks [ init-fdset ] keep ]
|
||||
[ write-fdset/tasks [ init-fdset ] keep ] tri
|
||||
f ;
|
||||
|
||||
M:: select-mx wait-for-events ( us mx -- )
|
||||
|
|
|
@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
|
|||
over get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] ushort-array{ } make underlying>>
|
||||
] ushort-array{ } make
|
||||
>>lpEnvironment
|
||||
] when ;
|
||||
|
||||
|
@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- )
|
|||
M: windows wait-for-processes ( -- ? )
|
||||
processes get keys dup
|
||||
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
|
||||
[ length ] [ underlying>> ] bi 0 0
|
||||
[ length ] keep 0 0
|
||||
WaitForMultipleObjects
|
||||
dup HEX: ffffffff = [ win32-error ] when
|
||||
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
||||
|
|
|
@ -7,5 +7,5 @@ QUALIFIED: io.pipes
|
|||
|
||||
M: unix io.pipes:(pipe) ( -- pair )
|
||||
2 <int-array>
|
||||
[ underlying>> pipe io-error ]
|
||||
[ pipe io-error ]
|
||||
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lcs xml.literals xml.writer kernel strings ;
|
||||
USING: lcs xml.syntax xml.writer kernel strings ;
|
||||
FROM: accessors => item>> ;
|
||||
FROM: io => write ;
|
||||
FROM: sequences => each if-empty when-empty map ;
|
||||
|
|
|
@ -75,14 +75,14 @@ PRIVATE>
|
|||
dup add-malloc ;
|
||||
|
||||
: realloc ( alien size -- newalien )
|
||||
[ >c-ptr ] dip
|
||||
over malloc-exists? [ realloc-error ] unless
|
||||
dupd (realloc) check-ptr
|
||||
swap delete-malloc
|
||||
dup add-malloc ;
|
||||
|
||||
: free ( alien -- )
|
||||
dup delete-malloc
|
||||
(free) ;
|
||||
>c-ptr [ delete-malloc ] [ (free) ] bi ;
|
||||
|
||||
: memcpy ( dst src size -- )
|
||||
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
|
||||
|
|
|
@ -256,7 +256,7 @@ XGEMM IS cblas_${T}gemm
|
|||
XGERU IS cblas_${T}ger${U}
|
||||
XGERC IS cblas_${T}ger${C}
|
||||
|
||||
MATRIX DEFINES ${TYPE}-blas-matrix
|
||||
MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
|
||||
<MATRIX> DEFINES <${TYPE}-blas-matrix>
|
||||
>MATRIX DEFINES >${TYPE}-blas-matrix
|
||||
XMATRIX{ DEFINES ${T}matrix{
|
||||
|
|
|
@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy
|
|||
XSWAP IS cblas_${T}swap
|
||||
IXAMAX IS cblas_i${T}amax
|
||||
|
||||
VECTOR DEFINES ${TYPE}-blas-vector
|
||||
VECTOR DEFINES-CLASS ${TYPE}-blas-vector
|
||||
<VECTOR> DEFINES <${TYPE}-blas-vector>
|
||||
>VECTOR DEFINES >${TYPE}-blas-vector
|
||||
|
||||
|
|
|
@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ;
|
|||
dup name>> empty-name? [
|
||||
drop
|
||||
] [
|
||||
[ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
|
||||
[ name-content>> ]
|
||||
[ name>> unquote ]
|
||||
[ mime-parts>> set-at ] tri
|
||||
] if ;
|
||||
|
|
|
@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
glMatrixMode glPopMatrix ; inline
|
||||
|
||||
: gl-material ( face pname params -- )
|
||||
float-array{ } like underlying>> glMaterialfv ;
|
||||
float-array{ } like glMaterialfv ;
|
||||
|
||||
: gl-vertex-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
|
||||
[ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
|
||||
|
||||
: gl-color-pointer ( seq -- )
|
||||
[ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
|
||||
[ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
|
||||
|
||||
: gl-texture-coord-pointer ( seq -- )
|
||||
[ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
|
||||
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
|
||||
|
||||
: line-vertices ( a b -- )
|
||||
[ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
|
||||
|
@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
glActiveTexture swap glBindTexture gl-error ;
|
||||
|
||||
: (set-draw-buffers) ( buffers -- )
|
||||
[ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
|
||||
[ length ] [ >uint-array ] bi glDrawBuffers ;
|
||||
|
||||
MACRO: set-draw-buffers ( buffers -- )
|
||||
words>values [ (set-draw-buffers) ] curry ;
|
||||
|
|
|
@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
|
|||
dup gl-program-shaders-length
|
||||
0 <int>
|
||||
over <uint-array>
|
||||
[ underlying>> glGetAttachedShaders ] keep ;
|
||||
[ glGetAttachedShaders ] keep ;
|
||||
|
||||
: delete-gl-program-only ( program -- )
|
||||
glDeleteProgram ; inline
|
||||
|
|
|
@ -31,7 +31,7 @@ ERROR: roman-range-error n ;
|
|||
] 2each drop ;
|
||||
|
||||
: (roman>) ( seq -- n )
|
||||
dup [ roman>n ] map swap all-eq? [
|
||||
[ [ roman>n ] map ] [ all-eq? ] bi [
|
||||
sum
|
||||
] [
|
||||
first2 swap -
|
||||
|
|
|
@ -1,5 +0,0 @@
|
|||
USING: sequences.next tools.test arrays kernel math sequences ;
|
||||
|
||||
[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test
|
||||
|
||||
[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test
|
|
@ -1,21 +0,0 @@
|
|||
USING: kernel sequences sequences.private math ;
|
||||
IN: sequences.next
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: iterate-seq ( seq quot -- i seq quot )
|
||||
[ [ length ] keep ] dip ; inline
|
||||
|
||||
: (map-next) ( i seq quot -- )
|
||||
! this uses O(n) more bounds checks than is really necessary
|
||||
[ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: each-next ( seq quot: ( next-elt elt -- ) -- )
|
||||
iterate-seq [ (map-next) ] 2curry each-integer ; inline
|
||||
|
||||
: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
|
||||
over dup length swap new-sequence [
|
||||
iterate-seq [ (map-next) ] 2curry
|
||||
] dip [ collect ] keep ; inline
|
|
@ -1 +0,0 @@
|
|||
Iteration with access to next element
|
|
@ -1 +0,0 @@
|
|||
collections
|
|
@ -11,7 +11,7 @@ A' IS ${T}-array
|
|||
>A' IS >${T}-array
|
||||
<A'> IS <${A'}>
|
||||
|
||||
A DEFINES direct-${T}-array
|
||||
A DEFINES-CLASS direct-${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
|
||||
NTH [ T dup c-getter array-accessor ]
|
||||
|
|
|
@ -15,7 +15,7 @@ M: bad-byte-array-length summary
|
|||
|
||||
FUNCTOR: define-array ( T -- )
|
||||
|
||||
A DEFINES ${T}-array
|
||||
A DEFINES-CLASS ${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
(A) DEFINES (${A})
|
||||
>A DEFINES >${A}
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
IN: specialized-arrays.tests
|
||||
USING: tools.test specialized-arrays sequences
|
||||
specialized-arrays.int specialized-arrays.bool
|
||||
specialized-arrays.ushort alien.c-types accessors kernel ;
|
||||
specialized-arrays.ushort alien.c-types accessors kernel
|
||||
specialized-arrays.direct.int arrays ;
|
||||
|
||||
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
|
||||
|
||||
|
@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ;
|
|||
] unit-test
|
||||
|
||||
[ B{ 210 4 1 } byte-array>ushort-array ] must-fail
|
||||
|
||||
[ { 3 1 3 3 7 } ] [
|
||||
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
|
||||
] unit-test
|
|
@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- )
|
|||
A IS ${T}-array
|
||||
<A> IS <${A}>
|
||||
|
||||
V DEFINES ${T}-vector
|
||||
V DEFINES-CLASS ${T}-vector
|
||||
<V> DEFINES <${V}>
|
||||
>V DEFINES >${V}
|
||||
V{ DEFINES ${V}{
|
||||
|
|
|
@ -42,3 +42,18 @@ C: <color> color
|
|||
[ bad-new-test ] must-infer
|
||||
|
||||
[ bad-new-test ] must-fail
|
||||
|
||||
! Corner case if macro expansion calls 'infer', found by Doug
|
||||
DEFER: smart-combo ( quot -- )
|
||||
|
||||
\ smart-combo [ infer [ ] curry ] 1 define-transform
|
||||
|
||||
[ [ "a" "b" "c" ] smart-combo ] must-infer
|
||||
|
||||
[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer
|
||||
|
||||
: very-smart-combo ( quot -- ) smart-combo ; inline
|
||||
|
||||
[ [ "a" "b" "c" ] very-smart-combo ] must-infer
|
||||
|
||||
[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors arrays kernel words sequences generic math
|
||||
namespaces make quotations assocs combinators classes.tuple
|
||||
classes.tuple.private effects summary hashtables classes generic
|
||||
sets definitions generic.standard slots.private continuations
|
||||
sets definitions generic.standard slots.private continuations locals
|
||||
stack-checker.backend stack-checker.state stack-checker.visitor
|
||||
stack-checker.errors stack-checker.values
|
||||
stack-checker.recursive-state ;
|
||||
|
@ -15,48 +15,32 @@ IN: stack-checker.transforms
|
|||
[ dup infer-word apply-word/effect ]
|
||||
if ;
|
||||
|
||||
: ((apply-transform)) ( word quot values stack -- )
|
||||
rot with-datastack first2
|
||||
dup [
|
||||
[
|
||||
[ drop ]
|
||||
[ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
|
||||
] 2dip
|
||||
swap infer-quot
|
||||
] [
|
||||
3drop give-up-transform
|
||||
] if ; inline
|
||||
:: ((apply-transform)) ( word quot values stack rstate -- )
|
||||
rstate recursive-state
|
||||
[ stack quot with-datastack first ] with-variable
|
||||
[
|
||||
word inlined-dependency depends-on
|
||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||
rstate infer-quot
|
||||
] [ word give-up-transform ] if* ;
|
||||
|
||||
: (apply-transform) ( word quot n -- )
|
||||
ensure-d dup [ known literal? ] all? [
|
||||
dup empty? [
|
||||
recursive-state get 1array
|
||||
] [
|
||||
dup empty? [ dup recursive-state get ] [
|
||||
[ ]
|
||||
[ [ literal value>> ] map ]
|
||||
[ first literal recursion>> ] tri
|
||||
prefix
|
||||
] if
|
||||
((apply-transform))
|
||||
] [ 2drop give-up-transform ] if ;
|
||||
|
||||
: apply-transform ( word -- )
|
||||
[ inlined-dependency depends-on ] [
|
||||
[ ]
|
||||
[ "transform-quot" word-prop ]
|
||||
[ "transform-n" word-prop ]
|
||||
tri
|
||||
(apply-transform)
|
||||
] bi ;
|
||||
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
|
||||
(apply-transform) ;
|
||||
|
||||
: apply-macro ( word -- )
|
||||
[ inlined-dependency depends-on ] [
|
||||
[ ]
|
||||
[ "macro" word-prop ]
|
||||
[ "declared-effect" word-prop in>> length ]
|
||||
tri
|
||||
(apply-transform)
|
||||
] bi ;
|
||||
[ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
|
||||
(apply-transform) ;
|
||||
|
||||
: define-transform ( word quot n -- )
|
||||
[ drop "transform-quot" set-word-prop ]
|
||||
|
|
|
@ -22,7 +22,7 @@ C-STRUCT: test-struct
|
|||
[ 5/4 ] [
|
||||
[
|
||||
2 "test-struct" malloc-struct-array
|
||||
dup underlying>> &free drop
|
||||
dup &free drop
|
||||
1 2 make-point over set-first
|
||||
3 4 make-point over set-second
|
||||
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
|
||||
|
@ -34,6 +34,6 @@ C-STRUCT: test-struct
|
|||
[ ] [
|
||||
[
|
||||
10 "test-struct" malloc-struct-array
|
||||
underlying>> &free drop
|
||||
&free drop
|
||||
] with-destructors
|
||||
] unit-test
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
||||
! Portions copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml.utilities kernel assocs math.order
|
||||
USING: xml.traversal kernel assocs math.order
|
||||
strings sequences xml.data xml.writer
|
||||
io.streams.string combinators xml xml.entities.html io.files io
|
||||
http.client namespaces make xml.literals hashtables
|
||||
http.client namespaces make xml.syntax hashtables
|
||||
calendar.format accessors continuations urls present ;
|
||||
IN: syndication
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: unicode.data sequences sequences.next namespaces
|
||||
USING: unicode.data sequences namespaces
|
||||
sbufs make unicode.syntax unicode.normalize math hints
|
||||
unicode.categories combinators unicode.syntax assocs
|
||||
strings splitting kernel accessors unicode.breaks fry locals ;
|
||||
|
|
|
@ -16,5 +16,5 @@ IN: unix.utilities
|
|||
'[ [ advance ] [ *void* _ alien>string ] bi ]
|
||||
[ ] produce nip ;
|
||||
|
||||
: strings>alien ( strings encoding -- alien )
|
||||
'[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ;
|
||||
: strings>alien ( strings encoding -- array )
|
||||
'[ _ malloc-string ] void*-array{ } map-as f suffix ;
|
||||
|
|
|
@ -132,7 +132,7 @@ unless
|
|||
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
|
||||
|
||||
: (callbacks>vtbl) ( callbacks -- vtbl )
|
||||
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
|
||||
[ execute ] void*-array{ } map-as malloc-byte-array ;
|
||||
: (callbacks>vtbls) ( callbacks -- vtbls )
|
||||
[ (callbacks>vtbl) ] map ;
|
||||
|
||||
|
|
|
@ -59,7 +59,7 @@ SYMBOLS:
|
|||
struct args <DIOBJECTDATAFORMAT>
|
||||
i alien set-nth
|
||||
] each-index
|
||||
alien underlying>>
|
||||
alien
|
||||
] ;
|
||||
|
||||
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
|
||||
|
|
|
@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ;
|
|||
"TARGETS" x-atom 32 PropModeReplace
|
||||
{
|
||||
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
|
||||
} [ x-atom ] int-array{ } map-as underlying>>
|
||||
} [ x-atom ] int-array{ } map-as
|
||||
4 XChangeProperty drop ;
|
||||
|
||||
: set-timestamp-prop ( evt -- )
|
||||
|
|
|
@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
|
|||
GLX_RGBA ,
|
||||
GLX_DEPTH_SIZE , 16 ,
|
||||
0 ,
|
||||
] int-array{ } make underlying>>
|
||||
] int-array{ } make
|
||||
glXChooseVisual
|
||||
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
|
||||
|
||||
|
|
|
@ -50,7 +50,7 @@ SYMBOL: keysym
|
|||
: lookup-string ( event xic -- string keysym )
|
||||
[
|
||||
prepare-lookup
|
||||
swap keybuf get underlying>> buf-size keysym get 0 <int>
|
||||
swap keybuf get buf-size keysym get 0 <int>
|
||||
XwcLookupString
|
||||
finish-lookup
|
||||
] with-scope ;
|
||||
|
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel xml arrays math generic http.client
|
||||
combinators hashtables namespaces io base64 sequences strings
|
||||
calendar xml.data xml.writer xml.utilities assocs math.parser
|
||||
debugger calendar.format math.order xml.literals xml.dispatch ;
|
||||
calendar xml.data xml.writer xml.traversal assocs math.parser
|
||||
debugger calendar.format math.order xml.syntax ;
|
||||
IN: xml-rpc
|
||||
|
||||
! * Sending RPC requests
|
||||
|
@ -113,14 +113,18 @@ M: server-error error.
|
|||
"Description: " write dup message>> print
|
||||
"Tag: " write tag>> xml>string print ;
|
||||
|
||||
PROCESS: xml>item ( tag -- object )
|
||||
TAGS: xml>item ( tag -- object )
|
||||
|
||||
TAG: string xml>item
|
||||
children>string ;
|
||||
|
||||
TAG: i4/int/double xml>item
|
||||
: children>number ( tag -- n )
|
||||
children>string string>number ;
|
||||
|
||||
TAG: i4 xml>item children>number ;
|
||||
TAG: int xml>item children>number ;
|
||||
TAG: double xml>item children>number ;
|
||||
|
||||
TAG: boolean xml>item
|
||||
dup children>string {
|
||||
{ [ dup "1" = ] [ 2drop t ] }
|
||||
|
@ -174,5 +178,5 @@ TAG: array xml>item
|
|||
! This needs to do something in the event of an error
|
||||
[ send-rpc ] dip http-post nip string>xml receive-rpc ;
|
||||
|
||||
: invoke-method ( params method url -- )
|
||||
: invoke-method ( params method url -- response )
|
||||
[ swap <rpc-method> ] dip post-rpc ;
|
||||
|
|
|
@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types"
|
|||
"Simple words for manipulating names:"
|
||||
{ $subsection names-match? }
|
||||
{ $subsection assure-name }
|
||||
"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
|
||||
"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ;
|
||||
|
||||
ARTICLE: { "xml.data" "classes" } "XML data classes"
|
||||
"XML documents and chunks are made of the following classes:"
|
||||
|
|
|
@ -1,25 +0,0 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
IN: xml.dispatch
|
||||
|
||||
ABOUT: "xml.dispatch"
|
||||
|
||||
ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
|
||||
"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
|
||||
{ $subsection POSTPONE: PROCESS: }
|
||||
"and to define a new 'method' for this word, use"
|
||||
{ $subsection POSTPONE: TAG: } ;
|
||||
|
||||
HELP: PROCESS:
|
||||
{ $syntax "PROCESS: word" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "creates a new word to process XML tags" }
|
||||
{ $see-also POSTPONE: TAG: } ;
|
||||
|
||||
HELP: TAG:
|
||||
{ $syntax "TAG: tag word definition... ;" }
|
||||
{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
|
||||
{ $description "defines what a process should do when it encounters a specific tag" }
|
||||
{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
||||
{ $see-also POSTPONE: PROCESS: } ;
|
|
@ -1,31 +0,0 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml io kernel math sequences strings xml.utilities
|
||||
tools.test math.parser xml.dispatch ;
|
||||
IN: xml.dispatch.tests
|
||||
|
||||
PROCESS: calculate ( tag -- n )
|
||||
|
||||
: calc-2children ( tag -- n n )
|
||||
children-tags first2 [ calculate ] dip calculate ;
|
||||
|
||||
TAG: number calculate
|
||||
children>string string>number ;
|
||||
TAG: add calculate
|
||||
calc-2children + ;
|
||||
TAG: minus calculate
|
||||
calc-2children - ;
|
||||
TAG: times calculate
|
||||
calc-2children * ;
|
||||
TAG: divide calculate
|
||||
calc-2children / ;
|
||||
TAG: neg calculate
|
||||
children-tags first calculate neg ;
|
||||
|
||||
: calc-arith ( string -- n )
|
||||
string>xml first-child-tag calculate ;
|
||||
|
||||
[ 32 ] [
|
||||
"<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
|
||||
calc-arith
|
||||
] unit-test
|
|
@ -1,27 +0,0 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words assocs kernel accessors parser sequences summary
|
||||
lexer splitting fry ;
|
||||
IN: xml.dispatch
|
||||
|
||||
TUPLE: process-missing process tag ;
|
||||
M: process-missing summary
|
||||
drop "Tag not implemented on process" ;
|
||||
|
||||
: run-process ( tag word -- )
|
||||
2dup "xtable" word-prop
|
||||
[ dup main>> ] dip at* [ 2nip call ] [
|
||||
drop \ process-missing boa throw
|
||||
] if ;
|
||||
|
||||
: PROCESS:
|
||||
CREATE
|
||||
dup H{ } clone "xtable" set-word-prop
|
||||
dup '[ _ run-process ] define ; parsing
|
||||
|
||||
: TAG:
|
||||
scan scan-word
|
||||
parse-definition
|
||||
swap "xtable" word-prop
|
||||
rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
|
||||
parsing
|
|
@ -1 +0,0 @@
|
|||
Daniel Ehrenberg
|
|
@ -1,60 +0,0 @@
|
|||
USING: help.markup help.syntax present multiline xml.data ;
|
||||
IN: xml.literals
|
||||
|
||||
ABOUT: "xml.literals"
|
||||
|
||||
ARTICLE: "xml.literals" "XML literals"
|
||||
"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
|
||||
{ $subsection POSTPONE: <XML }
|
||||
{ $subsection POSTPONE: [XML }
|
||||
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
|
||||
{ $subsection { "xml.literals" "interpolation" } } ;
|
||||
|
||||
HELP: <XML
|
||||
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
|
||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
|
||||
|
||||
HELP: [XML
|
||||
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
|
||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
|
||||
|
||||
ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax"
|
||||
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
|
||||
$nl
|
||||
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
|
||||
{ $example
|
||||
{" USING: splitting sequences xml.writer xml.literals ;
|
||||
"one two three" " " split
|
||||
[ [XML <item><-></item> XML] ] map
|
||||
<XML <doc><-></doc> XML> pprint-xml"}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<doc>
|
||||
<item>
|
||||
one
|
||||
</item>
|
||||
<item>
|
||||
two
|
||||
</item>
|
||||
<item>
|
||||
three
|
||||
</item>
|
||||
</doc>"} }
|
||||
"Here is an example of the locals version:"
|
||||
{ $example
|
||||
{" USING: locals urls xml.literals xml.writer ;
|
||||
[let |
|
||||
number [ 3 ]
|
||||
false [ f ]
|
||||
url [ URL" http://factorcode.org/" ]
|
||||
string [ "hello" ]
|
||||
word [ \ drop ] |
|
||||
<XML
|
||||
<x
|
||||
number=<-number->
|
||||
false=<-false->
|
||||
url=<-url->
|
||||
string=<-string->
|
||||
word=<-word-> />
|
||||
XML> pprint-xml ] "}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
|
|
@ -1,68 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test xml.literals multiline kernel assocs
|
||||
sequences accessors xml.writer xml.literals.private
|
||||
locals splitting urls xml.data classes ;
|
||||
IN: xml.literals.tests
|
||||
|
||||
[ "a" "c" { "a" "c" f } ] [
|
||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||
string>doc
|
||||
[ second var>> ]
|
||||
[ fourth "val" attr var>> ]
|
||||
[ extract-variables ] tri
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x>
|
||||
one
|
||||
<b val="two"/>
|
||||
y
|
||||
<foo/>
|
||||
</x>"} ] [
|
||||
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
|
||||
d [ [XML <-x-> <foo/> XML] ] |
|
||||
<XML
|
||||
<x> <-a-> <b val=<-c->/> <-d-> </x>
|
||||
XML> pprint-xml>string
|
||||
]
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<doc>
|
||||
<item>
|
||||
one
|
||||
</item>
|
||||
<item>
|
||||
two
|
||||
</item>
|
||||
<item>
|
||||
three
|
||||
</item>
|
||||
</doc>"} ] [
|
||||
"one two three" " " split
|
||||
[ [XML <item><-></item> XML] ] map
|
||||
<XML <doc><-></doc> XML> pprint-xml>string
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
|
||||
[ 3 f URL" http://factorcode.org/" "hello" \ drop
|
||||
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
|
||||
pprint-xml>string ] unit-test
|
||||
|
||||
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
|
||||
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
|
||||
|
||||
\ <XML must-infer
|
||||
[ { } "" interpolate-xml ] must-infer
|
||||
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
|
||||
|
||||
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
|
||||
[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
|
||||
[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
|
||||
[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
|
||||
[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
|
||||
[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
|
||||
|
||||
[ "" ] [ [XML XML] concat ] unit-test
|
|
@ -1,109 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml xml.state kernel sequences fry assocs xml.data
|
||||
accessors strings make multiline parser namespaces macros
|
||||
sequences.deep generalizations words combinators
|
||||
math present arrays unicode.categories ;
|
||||
IN: xml.literals
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: string>chunk ( string -- chunk )
|
||||
t interpolating? [ string>xml-chunk ] with-variable ;
|
||||
|
||||
: string>doc ( string -- xml )
|
||||
t interpolating? [ string>xml ] with-variable ;
|
||||
|
||||
DEFER: interpolate-sequence
|
||||
|
||||
: interpolate-attrs ( table attrs -- attrs )
|
||||
swap '[
|
||||
dup interpolated?
|
||||
[ var>> _ at dup [ present ] when ] when
|
||||
] assoc-map [ nip ] assoc-filter ;
|
||||
|
||||
: interpolate-tag ( table tag -- tag )
|
||||
[ nip name>> ]
|
||||
[ attrs>> interpolate-attrs ]
|
||||
[ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri
|
||||
<tag> ;
|
||||
|
||||
GENERIC: push-item ( item -- )
|
||||
M: string push-item , ;
|
||||
M: xml-data push-item , ;
|
||||
M: object push-item present , ;
|
||||
M: sequence push-item
|
||||
dup xml-data? [ , ] [ [ push-item ] each ] if ;
|
||||
M: number push-item present , ;
|
||||
M: xml-chunk push-item % ;
|
||||
|
||||
GENERIC: interpolate-item ( table item -- )
|
||||
M: object interpolate-item nip , ;
|
||||
M: tag interpolate-item interpolate-tag , ;
|
||||
M: interpolated interpolate-item
|
||||
var>> swap at push-item ;
|
||||
|
||||
: interpolate-sequence ( table seq -- seq )
|
||||
[ [ interpolate-item ] with each ] { } make ;
|
||||
|
||||
: interpolate-xml-doc ( table xml -- xml )
|
||||
(clone) [ interpolate-tag ] change-body ;
|
||||
|
||||
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
|
||||
{
|
||||
{ [ over interpolated? ] [ call ] }
|
||||
{ [ over tag? ] [
|
||||
[ attrs>> values [ interpolated? ] filter ] dip each
|
||||
] }
|
||||
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
|
||||
[ 2drop ]
|
||||
} cond ; inline recursive
|
||||
|
||||
: each-interpolated ( xml quot -- )
|
||||
'[ _ (each-interpolated) ] deep-each ; inline
|
||||
|
||||
: number<-> ( doc -- dup )
|
||||
0 over [
|
||||
dup var>> [
|
||||
over >>var [ 1+ ] dip
|
||||
] unless drop
|
||||
] each-interpolated drop ;
|
||||
|
||||
GENERIC: interpolate-xml ( table xml -- xml )
|
||||
|
||||
M: xml interpolate-xml
|
||||
interpolate-xml-doc ;
|
||||
|
||||
M: xml-chunk interpolate-xml
|
||||
interpolate-sequence <xml-chunk> ;
|
||||
|
||||
: >search-hash ( seq -- hash )
|
||||
[ dup search ] H{ } map>assoc ;
|
||||
|
||||
: extract-variables ( xml -- seq )
|
||||
[ [ var>> , ] each-interpolated ] { } make ;
|
||||
|
||||
: nenum ( ... n -- assoc )
|
||||
narray <enum> ; inline
|
||||
|
||||
: collect ( accum variables -- accum ? )
|
||||
{
|
||||
{ [ dup empty? ] [ drop f ] } ! Just a literal
|
||||
{ [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
|
||||
{ [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
|
||||
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
|
||||
} cond ;
|
||||
|
||||
: parse-def ( accum delimiter quot -- accum )
|
||||
[ parse-multiline-string [ blank? ] trim ] dip call
|
||||
[ extract-variables collect ] keep swap
|
||||
[ number<-> parsed ] dip
|
||||
[ \ interpolate-xml parsed ] when ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <XML
|
||||
"XML>" [ string>doc ] parse-def ; parsing
|
||||
|
||||
: [XML
|
||||
"XML]" [ string>chunk ] parse-def ; parsing
|
|
@ -1 +0,0 @@
|
|||
Syntax for XML interpolation
|
|
@ -1,2 +0,0 @@
|
|||
syntax
|
||||
enterprise
|
|
@ -0,0 +1,101 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax xml.data present multiline ;
|
||||
IN: xml.syntax
|
||||
|
||||
ABOUT: "xml.syntax"
|
||||
|
||||
ARTICLE: "xml.syntax" "Syntax extensions for XML"
|
||||
"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing."
|
||||
{ $subsection { "xml.syntax" "tags" } }
|
||||
{ $subsection { "xml.syntax" "literals" } }
|
||||
{ $subsection POSTPONE: XML-NS: } ;
|
||||
|
||||
ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
|
||||
"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
|
||||
{ $subsection POSTPONE: TAGS: }
|
||||
"and to define a new 'method' for this word, use"
|
||||
{ $subsection POSTPONE: TAG: } ;
|
||||
|
||||
HELP: TAGS:
|
||||
{ $syntax "TAGS: word" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "Creates a new word to which dispatches on XML tag names." }
|
||||
{ $see-also POSTPONE: TAG: } ;
|
||||
|
||||
HELP: TAG:
|
||||
{ $syntax "TAG: tag word definition... ;" }
|
||||
{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
|
||||
{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
|
||||
{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
||||
{ $see-also POSTPONE: TAGS: } ;
|
||||
|
||||
ARTICLE: { "xml.syntax" "literals" } "XML literals"
|
||||
"The following words provide syntax for XML literals:"
|
||||
{ $subsection POSTPONE: <XML }
|
||||
{ $subsection POSTPONE: [XML }
|
||||
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
|
||||
{ $subsection { "xml.syntax" "interpolation" } } ;
|
||||
|
||||
HELP: <XML
|
||||
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
|
||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
||||
|
||||
HELP: [XML
|
||||
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
|
||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
||||
|
||||
ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
|
||||
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
|
||||
$nl
|
||||
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
|
||||
{ $example
|
||||
{" USING: splitting sequences xml.writer xml.syntax ;
|
||||
"one two three" " " split
|
||||
[ [XML <item><-></item> XML] ] map
|
||||
<XML <doc><-></doc> XML> pprint-xml"}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<doc>
|
||||
<item>
|
||||
one
|
||||
</item>
|
||||
<item>
|
||||
two
|
||||
</item>
|
||||
<item>
|
||||
three
|
||||
</item>
|
||||
</doc>"} }
|
||||
"Here is an example of the locals version:"
|
||||
{ $example
|
||||
{" USING: locals urls xml.syntax xml.writer ;
|
||||
[let |
|
||||
number [ 3 ]
|
||||
false [ f ]
|
||||
url [ URL" http://factorcode.org/" ]
|
||||
string [ "hello" ]
|
||||
word [ \ drop ] |
|
||||
<XML
|
||||
<x
|
||||
number=<-number->
|
||||
false=<-false->
|
||||
url=<-url->
|
||||
string=<-string->
|
||||
word=<-word-> />
|
||||
XML> pprint-xml ] "}
|
||||
{" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
|
||||
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
|
||||
{ $example {" USING: sequences xml.syntax inverse ;
|
||||
: dispatch ( xml -- string )
|
||||
{
|
||||
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
|
||||
{ [ [XML <b><-></b> XML] ] [ "b" prepend ] }
|
||||
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
|
||||
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
|
||||
} switch ;
|
||||
[XML <a>pple</a> XML] dispatch write "} "apple" } ;
|
||||
|
||||
HELP: XML-NS:
|
||||
{ $syntax "XML-NS: name http://url" }
|
||||
{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ;
|
|
@ -0,0 +1,138 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml io kernel math sequences strings xml.traversal
|
||||
tools.test math.parser xml.syntax xml.data xml.syntax.private
|
||||
accessors multiline locals inverse xml.writer splitting classes ;
|
||||
IN: xml.syntax.tests
|
||||
|
||||
! TAGS test
|
||||
|
||||
TAGS: calculate ( tag -- n )
|
||||
|
||||
: calc-2children ( tag -- n n )
|
||||
children-tags first2 [ calculate ] dip calculate ;
|
||||
|
||||
TAG: number calculate
|
||||
children>string string>number ;
|
||||
TAG: add calculate
|
||||
calc-2children + ;
|
||||
TAG: minus calculate
|
||||
calc-2children - ;
|
||||
TAG: times calculate
|
||||
calc-2children * ;
|
||||
TAG: divide calculate
|
||||
calc-2children / ;
|
||||
TAG: neg calculate
|
||||
children-tags first calculate neg ;
|
||||
|
||||
: calc-arith ( string -- n )
|
||||
string>xml first-child-tag calculate ;
|
||||
|
||||
[ 32 ] [
|
||||
"<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
|
||||
calc-arith
|
||||
] unit-test
|
||||
|
||||
\ calc-arith must-infer
|
||||
|
||||
XML-NS: foo http://blah.com
|
||||
|
||||
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
|
||||
|
||||
! XML literals
|
||||
|
||||
[ "a" "c" { "a" "c" f } ] [
|
||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||
string>doc
|
||||
[ second var>> ]
|
||||
[ fourth "val" attr var>> ]
|
||||
[ extract-variables ] tri
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x>
|
||||
one
|
||||
<b val="two"/>
|
||||
y
|
||||
<foo/>
|
||||
</x>"} ] [
|
||||
[let* | a [ "one" ] c [ "two" ] x [ "y" ]
|
||||
d [ [XML <-x-> <foo/> XML] ] |
|
||||
<XML
|
||||
<x> <-a-> <b val=<-c->/> <-d-> </x>
|
||||
XML> pprint-xml>string
|
||||
]
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<doc>
|
||||
<item>
|
||||
one
|
||||
</item>
|
||||
<item>
|
||||
two
|
||||
</item>
|
||||
<item>
|
||||
three
|
||||
</item>
|
||||
</doc>"} ] [
|
||||
"one two three" " " split
|
||||
[ [XML <item><-></item> XML] ] map
|
||||
<XML <doc><-></doc> XML> pprint-xml>string
|
||||
] unit-test
|
||||
|
||||
[ {" <?xml version="1.0" encoding="UTF-8"?>
|
||||
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
|
||||
[ 3 f "http://factorcode.org/" "hello" \ drop
|
||||
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
|
||||
pprint-xml>string ] unit-test
|
||||
|
||||
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
|
||||
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
|
||||
|
||||
\ <XML must-infer
|
||||
[ [XML <-> XML] ] must-infer
|
||||
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
|
||||
|
||||
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
|
||||
[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
|
||||
[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
|
||||
[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
|
||||
[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
|
||||
[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
|
||||
|
||||
[ "" ] [ [XML XML] concat ] unit-test
|
||||
|
||||
USE: inverse
|
||||
|
||||
[ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
|
||||
[ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
|
||||
[ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
|
||||
|
||||
: dispatch ( xml -- string )
|
||||
{
|
||||
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
|
||||
{ [ [XML <b><-></b> XML] ] [ "b" prepend ] }
|
||||
{ [ [XML <b val='yes'/> XML] ] [ "byes" ] }
|
||||
{ [ [XML <b val=<->/> XML] ] [ "bno" prepend ] }
|
||||
} switch ;
|
||||
|
||||
[ "apple" ] [ [XML <a>pple</a> XML] dispatch ] unit-test
|
||||
[ "banana" ] [ [XML <b>anana</b> XML] dispatch ] unit-test
|
||||
[ "byes" ] [ [XML <b val="yes"/> XML] dispatch ] unit-test
|
||||
[ "bnowhere" ] [ [XML <b val="where"/> XML] dispatch ] unit-test
|
||||
[ "baboon" ] [ [XML <b val="something">aboon</b> XML] dispatch ] unit-test
|
||||
[ "apple" ] [ <XML <a>pple</a> XML> dispatch ] unit-test
|
||||
[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch ] unit-test
|
||||
|
||||
: dispatch-doc ( xml -- string )
|
||||
{
|
||||
{ [ <XML <a><-></a> XML> ] [ "a" prepend ] }
|
||||
{ [ <XML <b><-></b> XML> ] [ "b" prepend ] }
|
||||
{ [ <XML <b val='yes'/> XML> ] [ "byes" ] }
|
||||
{ [ <XML <b val=<->/> XML> ] [ "bno" prepend ] }
|
||||
} switch ;
|
||||
|
||||
[ "apple" ] [ <XML <a>pple</a> XML> dispatch-doc ] unit-test
|
||||
[ "apple" ] [ [XML <a>pple</a> XML] dispatch-doc ] unit-test
|
||||
[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch-doc ] unit-test
|
|
@ -0,0 +1,243 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words assocs kernel accessors parser sequences summary
|
||||
lexer splitting combinators locals xml.data memoize sequences.deep
|
||||
xml.data xml.state xml namespaces present arrays generalizations strings
|
||||
make math macros multiline inverse combinators.short-circuit
|
||||
sorting fry unicode.categories ;
|
||||
IN: xml.syntax
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: no-tag name word ;
|
||||
M: no-tag summary
|
||||
drop "The tag-dispatching word has no method for the given tag name" ;
|
||||
|
||||
: compile-tags ( word xtable -- quot )
|
||||
>alist swap '[ _ no-tag boa throw ] suffix
|
||||
'[ dup main>> _ case ] ;
|
||||
|
||||
: define-tags ( word -- )
|
||||
dup dup "xtable" word-prop compile-tags define ;
|
||||
|
||||
:: define-tag ( string word quot -- )
|
||||
quot string word "xtable" word-prop set-at
|
||||
word define-tags ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: TAGS:
|
||||
CREATE
|
||||
[ H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ] bi ; parsing
|
||||
|
||||
: TAG:
|
||||
scan scan-word parse-definition define-tag ; parsing
|
||||
|
||||
: XML-NS:
|
||||
CREATE-WORD (( string -- name )) over set-stack-effect
|
||||
scan '[ f swap _ <name> ] define-memoized ; parsing
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: each-attrs ( attrs quot -- )
|
||||
[ values [ interpolated? ] filter ] dip each ; inline
|
||||
|
||||
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
|
||||
{
|
||||
{ [ over interpolated? ] [ call ] }
|
||||
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
|
||||
{ [ over attrs? ] [ each-attrs ] }
|
||||
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
|
||||
[ 2drop ]
|
||||
} cond ; inline recursive
|
||||
|
||||
: each-interpolated ( xml quot -- )
|
||||
'[ _ (each-interpolated) ] deep-each ; inline
|
||||
|
||||
: has-interpolated? ( xml -- ? )
|
||||
! If this becomes a performance problem, it can be improved
|
||||
f swap [ 2drop t ] each-interpolated ;
|
||||
|
||||
: when-interpolated ( xml quot -- genquot )
|
||||
[ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
|
||||
|
||||
: string>chunk ( string -- chunk )
|
||||
t interpolating? [ string>xml-chunk ] with-variable ;
|
||||
|
||||
: string>doc ( string -- xml )
|
||||
t interpolating? [ string>xml ] with-variable ;
|
||||
|
||||
DEFER: interpolate-sequence
|
||||
|
||||
: get-interpolated ( interpolated -- quot )
|
||||
var>> '[ [ _ swap at ] keep ] ;
|
||||
|
||||
: ?present ( object -- string )
|
||||
dup [ present ] when ;
|
||||
|
||||
: interpolate-attr ( key value -- quot )
|
||||
dup interpolated?
|
||||
[ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
|
||||
[ 2array '[ _ swap ] ] if ;
|
||||
|
||||
: filter-nulls ( assoc -- newassoc )
|
||||
[ nip ] assoc-filter ;
|
||||
|
||||
: interpolate-attrs ( attrs -- quot )
|
||||
[
|
||||
[ [ interpolate-attr ] { } assoc>map [ ] join ]
|
||||
[ assoc-size ] bi
|
||||
'[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
: interpolate-tag ( tag -- quot )
|
||||
[
|
||||
[ name>> ]
|
||||
[ attrs>> interpolate-attrs ]
|
||||
[ children>> interpolate-sequence ] tri
|
||||
'[ _ swap @ @ [ <tag> ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
GENERIC: push-item ( item -- )
|
||||
M: string push-item , ;
|
||||
M: xml-data push-item , ;
|
||||
M: object push-item present , ;
|
||||
M: sequence push-item
|
||||
dup xml-data? [ , ] [ [ push-item ] each ] if ;
|
||||
M: number push-item present , ;
|
||||
M: xml-chunk push-item % ;
|
||||
|
||||
: concat-interpolate ( array -- newarray )
|
||||
[ [ push-item ] each ] { } make ;
|
||||
|
||||
GENERIC: interpolate-item ( item -- quot )
|
||||
M: object interpolate-item [ swap ] curry ;
|
||||
M: tag interpolate-item interpolate-tag ;
|
||||
M: interpolated interpolate-item get-interpolated ;
|
||||
|
||||
: interpolate-sequence ( seq -- quot )
|
||||
[
|
||||
[ [ interpolate-item ] map concat ]
|
||||
[ length ] bi
|
||||
'[ @ _ swap [ narray concat-interpolate ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
GENERIC: [interpolate-xml] ( xml -- quot )
|
||||
|
||||
M: xml [interpolate-xml]
|
||||
dup body>> interpolate-tag
|
||||
'[ _ (clone) swap @ drop >>body ] ;
|
||||
|
||||
M: xml-chunk [interpolate-xml]
|
||||
interpolate-sequence
|
||||
'[ @ drop <xml-chunk> ] ;
|
||||
|
||||
MACRO: interpolate-xml ( xml -- quot )
|
||||
[interpolate-xml] ;
|
||||
|
||||
: number<-> ( doc -- dup )
|
||||
0 over [
|
||||
dup var>> [
|
||||
over >>var [ 1+ ] dip
|
||||
] unless drop
|
||||
] each-interpolated drop ;
|
||||
|
||||
: >search-hash ( seq -- hash )
|
||||
[ dup search ] H{ } map>assoc ;
|
||||
|
||||
: extract-variables ( xml -- seq )
|
||||
[ [ var>> , ] each-interpolated ] { } make ;
|
||||
|
||||
: nenum ( ... n -- assoc )
|
||||
narray <enum> ; inline
|
||||
|
||||
: collect ( accum variables -- accum ? )
|
||||
{
|
||||
{ [ dup empty? ] [ drop f ] } ! Just a literal
|
||||
{ [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
|
||||
{ [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
|
||||
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
|
||||
} cond ;
|
||||
|
||||
: parse-def ( accum delimiter quot -- accum )
|
||||
[ parse-multiline-string [ blank? ] trim ] dip call
|
||||
[ extract-variables collect ] keep swap
|
||||
[ number<-> parsed ] dip
|
||||
[ \ interpolate-xml parsed ] when ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <XML
|
||||
"XML>" [ string>doc ] parse-def ; parsing
|
||||
|
||||
: [XML
|
||||
"XML]" [ string>chunk ] parse-def ; parsing
|
||||
|
||||
: remove-blanks ( seq -- newseq )
|
||||
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
|
||||
|
||||
GENERIC: >xml ( xml -- tag )
|
||||
M: xml >xml body>> ;
|
||||
M: tag >xml ;
|
||||
M: xml-chunk >xml
|
||||
remove-blanks
|
||||
[ length 1 =/fail ]
|
||||
[ first dup tag? [ fail ] unless ] bi ;
|
||||
M: object >xml fail ;
|
||||
|
||||
: 1chunk ( object -- xml-chunk )
|
||||
1array <xml-chunk> ;
|
||||
|
||||
GENERIC: >xml-chunk ( xml -- chunk )
|
||||
M: xml >xml-chunk body>> 1chunk ;
|
||||
M: xml-chunk >xml-chunk ;
|
||||
M: object >xml-chunk 1chunk ;
|
||||
|
||||
GENERIC: [undo-xml] ( xml -- quot )
|
||||
|
||||
M: xml [undo-xml]
|
||||
body>> [undo-xml] '[ >xml @ ] ;
|
||||
|
||||
M: xml-chunk [undo-xml]
|
||||
seq>> [undo-xml] '[ >xml-chunk @ ] ;
|
||||
|
||||
: undo-attrs ( attrs -- quot: ( attrs -- ) )
|
||||
[
|
||||
[ main>> ] dip dup interpolated?
|
||||
[ var>> '[ _ attr _ set ] ]
|
||||
[ '[ _ attr _ =/fail ] ] if
|
||||
] { } assoc>map '[ _ cleave ] ;
|
||||
|
||||
M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
|
||||
{
|
||||
[ name>> main>> '[ name>> main>> _ =/fail ] ]
|
||||
[ attrs>> undo-attrs ]
|
||||
[ children>> [undo-xml] '[ children>> @ ] ]
|
||||
} cleave '[ _ _ _ tri ] ;
|
||||
|
||||
: firstn-strong ( seq n -- ... )
|
||||
[ swap length =/fail ]
|
||||
[ firstn ] 2bi ; inline
|
||||
|
||||
M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
|
||||
remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
|
||||
'[ remove-blanks _ firstn-strong _ spread ] ;
|
||||
|
||||
M: string [undo-xml] ( string -- quot: ( string -- ) )
|
||||
'[ _ =/fail ] ;
|
||||
|
||||
M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
|
||||
'[ _ =/fail ] ;
|
||||
|
||||
M: interpolated [undo-xml]
|
||||
var>> '[ _ set ] ;
|
||||
|
||||
: >enum ( assoc -- enum )
|
||||
! Assumes keys are 0..n
|
||||
>alist sort-keys values <enum> ;
|
||||
|
||||
: undo-xml ( xml -- quot )
|
||||
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
|
||||
|
||||
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
|
|
@ -1,4 +1,4 @@
|
|||
USING: xml xml.data xml.utilities tools.test accessors kernel
|
||||
USING: xml xml.data xml.traversal tools.test accessors kernel
|
||||
io.encodings.8-bit ;
|
||||
|
||||
[ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
|
||||
USING: sequences xml kernel arrays xml.traversal io.files tools.test ;
|
||||
IN: xml.tests
|
||||
|
||||
: assemble-data ( tag -- 3array )
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel xml sequences assocs tools.test io arrays namespaces fry
|
||||
accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ;
|
||||
accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
|
||||
IN: xml.tests
|
||||
|
||||
: sub-tag
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
IN: xml.tests
|
||||
USING: kernel xml tools.test io namespaces make sequences
|
||||
xml.errors xml.entities.html parser strings xml.data io.files
|
||||
xml.utilities continuations assocs
|
||||
xml.traversal continuations assocs
|
||||
sequences.deep accessors io.streams.string ;
|
||||
|
||||
! This is insufficient
|
||||
|
@ -67,3 +67,4 @@ SYMBOL: xml-file
|
|||
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
|
||||
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
|
||||
[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
|
||||
[ "1.1" ] [ "<?xml version='1.1'?><x/>" string>xml prolog>> version>> ] unit-test
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue