steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into fortran

db4
Joe Groff 2009-02-06 10:07:35 -06:00
parent 7e2ac604e7 5579de1722
commit da05150686
132 changed files with 1741 additions and 663 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
Makefile
View File

@ -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) \

17
basis/alien/arrays/arrays.factor
View File

@ -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 ] ;

2
basis/alien/c-types/c-types-docs.factor
View File

@ -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

9
basis/alien/c-types/c-types.factor
View File

@ -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

1
basis/alien/complex/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

18
basis/alien/complex/complex-tests.factor Normal file
View File

@ -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

6
basis/alien/complex/complex.factor Normal file
View File

@ -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 >>

1
basis/alien/complex/functor/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/alien/complex/functor/functor-tests.factor Normal file
View File

@ -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

35
basis/alien/complex/functor/functor.factor Normal file
View File

@ -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

1
basis/alien/complex/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation details for C99 complex float and complex double types

11
basis/alien/structs/structs.factor
View File

@ -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 )

2
basis/cocoa/messages/messages.factor
View File

@ -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 -- )

2
basis/cocoa/views/views.factor
View File

@ -68,7 +68,7 @@ PRIVATE>
NSOpenGLPFASamples , 8 ,
] when
0 ,
] int-array{ } make underlying>>
] int-array{ } make
-> initWithAttributes:
-> autorelease ;

1
basis/colors/constants/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

6
basis/colors/constants/constants-tests.factor Normal file
View File

@ -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

31
basis/colors/constants/constants.factor Normal file
View File

@ -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

753
basis/colors/constants/rgb.txt Normal file
View File

@ -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

1
basis/colors/constants/summary.txt Normal file
View File

@ -0,0 +1 @@
A utility to look up colors in the X11 rgb.txt color database

8
basis/combinators/smart/smart-tests.factor
View File

@ -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

4
basis/compiler/codegen/codegen.factor
View File

@ -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

11
basis/compiler/tests/alien.factor
View File

@ -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

6
basis/db/postgresql/lib/lib.factor
View File

@ -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 )
[

2
basis/farkup/farkup-tests.factor
View File

@ -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
basis/farkup/farkup.factor
View File

@ -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

51
basis/functors/functors-tests.factor
View File

@ -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

11
basis/functors/functors.factor
View File

@ -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

4
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -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

2
basis/help/html/html.factor
View File

@ -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 -- )

2
basis/html/components/components-docs.factor
View File

@ -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"

2
basis/html/components/components.factor
View File

@ -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
basis/html/elements/elements.factor
View File

@ -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
basis/html/forms/forms.factor
View File

@ -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 ;

4
basis/html/html.factor
View File

@ -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] ;

2
basis/html/streams/streams.factor
View File

@ -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

2
basis/html/templates/chloe/chloe.factor
View File

@ -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

2
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -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 ;

2
basis/html/templates/templates.factor
View File

@ -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

2
basis/http/http-tests.factor
View File

@ -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

2
basis/http/server/responses/responses.factor
View File

@ -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

2
basis/http/server/static/static.factor
View File

@ -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

0
basis/sequences/next/authors.txt → basis/inverse/authors.txt
View File

0
extra/inverse/inverse-docs.factor → basis/inverse/inverse-docs.factor
View File

3
extra/inverse/inverse-tests.factor → basis/inverse/inverse-tests.factor
View File

@ -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
extra/inverse/inverse.factor → basis/inverse/inverse.factor
View File

@ -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

0
extra/inverse/summary.txt → basis/inverse/summary.txt
View File

0
extra/inverse/tags.txt → basis/inverse/tags.txt
View File

2
basis/io/backend/unix/multiplexers/epoll/epoll.factor
View File

@ -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 -- )

2
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -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 -- )

4
basis/io/backend/unix/multiplexers/select/select.factor
View File

@ -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 -- )

4
basis/io/launcher/windows/windows.factor
View File

@ -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 ;

2
basis/io/pipes/unix/unix.factor
View File

@ -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 ;

2
basis/lcs/diff2html/diff2html.factor
View File

@ -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 ;

4
basis/libc/libc.factor
View File

@ -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 ;

2
basis/math/blas/matrices/matrices.factor
View File

@ -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{

2
basis/math/blas/vectors/vectors.factor
View File

@ -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

2
basis/mime/multipart/multipart.factor
View File

@ -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 ;

10
basis/opengl/opengl.factor
View File

@ -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 ;

2
basis/opengl/shaders/shaders.factor
View File

@ -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

2
basis/roman/roman.factor
View File

@ -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 -

5
basis/sequences/next/next-tests.factor
View File

@ -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

21
basis/sequences/next/next.factor
View File

@ -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
basis/sequences/next/summary.txt
View File

@ -1 +0,0 @@
Iteration with access to next element

1
basis/sequences/next/tags.txt
View File

@ -1 +0,0 @@
collections

2
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -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 ]

2
basis/specialized-arrays/functor/functor.factor
View File

@ -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}

7
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -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

2
basis/specialized-vectors/functor/functor.factor
View File

@ -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}{

15
basis/stack-checker/transforms/transforms-tests.factor
View File

@ -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

46
basis/stack-checker/transforms/transforms.factor
View File

@ -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 ]

4
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -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

4
basis/syndication/syndication.factor
View File

@ -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

2
basis/unicode/case/case.factor
View File

@ -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 ;

4
basis/unix/utilities/utilities.factor
View File

@ -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 ;

2
basis/windows/com/wrapper/wrapper.factor
View File

@ -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 ;

2
basis/windows/dinput/constants/constants.factor
View File

@ -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 )

2
basis/x11/clipboard/clipboard.factor
View File

@ -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 -- )

2
basis/x11/glx/glx.factor
View File

@ -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* ;

2
basis/x11/xim/xim.factor
View File

@ -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 ;

14
basis/xml-rpc/xml-rpc.factor
View File

@ -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 ;

2
basis/xml/data/data-docs.factor
View File

@ -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:"

25
basis/xml/dispatch/dispatch-docs.factor
View File

@ -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: } ;

31
basis/xml/dispatch/dispatch-tests.factor
View File

@ -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

27
basis/xml/dispatch/dispatch.factor
View File

@ -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
basis/xml/literals/authors.txt
View File

@ -1 +0,0 @@
Daniel Ehrenberg

60
basis/xml/literals/literals-docs.factor
View File

@ -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"/>"} } ;

68
basis/xml/literals/literals-tests.factor
View File

@ -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

109
basis/xml/literals/literals.factor
View File

@ -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
basis/xml/literals/summary.txt
View File

@ -1 +0,0 @@
Syntax for XML interpolation

2
basis/xml/literals/tags.txt
View File

@ -1,2 +0,0 @@
syntax
enterprise

0
basis/xml/dispatch/authors.txt → basis/xml/syntax/authors.txt
View File

0
basis/xml/dispatch/summary.txt → basis/xml/syntax/summary.txt
View File

101
basis/xml/syntax/syntax-docs.factor Normal file
View File

@ -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." } ;

138
basis/xml/syntax/syntax-tests.factor Normal file
View File

@ -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

243
basis/xml/syntax/syntax.factor Normal file
View File

@ -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

0
basis/xml/dispatch/tags.txt → basis/xml/syntax/tags.txt
View File

2
basis/xml/tests/encodings.factor
View File

@ -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

2
basis/xml/tests/soap.factor
View File

@ -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 )

2
basis/xml/tests/templating.factor
View File

@ -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
basis/xml/tests/test.factor
View File

@ -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='&lt;'/>" 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