From a1f4f7772f988f7fd0cf84598a378747807acb01 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 5 Feb 2009 23:59:36 -0600
Subject: [PATCH 01/16] make multipart work with sessions
---
basis/mime/multipart/multipart.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor
index fc3024bd01..eda7849a73 100755
--- a/basis/mime/multipart/multipart.factor
+++ b/basis/mime/multipart/multipart.factor
@@ -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 ;
From f31e19a66669c1c280858755a3a483eededd7490 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 6 Feb 2009 00:01:28 -0600
Subject: [PATCH 02/16] refactoring graphics.bitmap
---
extra/graphics/bitmap/bitmap-tests.factor | 15 +++
extra/graphics/bitmap/bitmap.factor | 155 +++++++++-------------
extra/graphics/viewer/viewer.factor | 33 ++++-
3 files changed, 108 insertions(+), 95 deletions(-)
create mode 100644 extra/graphics/bitmap/bitmap-tests.factor
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
new file mode 100644
index 0000000000..4998427b22
--- /dev/null
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -0,0 +1,15 @@
+USING: graphics.bitmap ;
+IN: graphics.bitmap.tests
+
+: test-bitmap24 ( -- )
+ "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
+
+: test-bitmap8 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
+
+: test-bitmap4 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
+
+: test-bitmap1 ( -- )
+ "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
+
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index a0212e47de..bd34a9ee41 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary
-graphics.viewer io io.binary io.files kernel libc math
+io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ;
@@ -12,10 +12,11 @@ IN: graphics.bitmap
! Handles row-reversed bitmaps (their height is negative)
TUPLE: bitmap magic size reserved offset header-length width
- height planes bit-count compression size-image
- x-pels y-pels color-used color-important rgb-quads color-index array ;
+height planes bit-count compression size-image
+x-pels y-pels color-used color-important rgb-quads color-index
+array ;
-: (array-copy) ( bitmap array -- bitmap array' )
+: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- )
@@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- )
2over * _ * >>size-image
swap >>height
swap >>width
- swap (array-copy) [ >>array ] [ >>color-index ] bi
+ swap array-copy [ >>array ] [ >>color-index ] bi
_ >>bit-count
] ;
@@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- )
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
- { 32 [ "32bit" throw ] }
+ { 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
{ 8 [ 8bit>array ] }
@@ -59,107 +60,75 @@ ERROR: bitmap-magic ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
-: parse-file-header ( bitmap -- )
- 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
- 4 read le> >>size
- 4 read le> >>reserved
- 4 read le> >>offset drop ;
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
-: parse-bitmap-header ( bitmap -- )
- 4 read le> >>header-length
- 4 read signed-le> >>width
- 4 read signed-le> >>height
- 2 read le> >>planes
- 2 read le> >>bit-count
- 4 read le> >>compression
- 4 read le> >>size-image
- 4 read le> >>x-pels
- 4 read le> >>y-pels
- 4 read le> >>color-used
- 4 read le> >>color-important drop ;
+: parse-file-header ( bitmap -- bitmap )
+ 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+ read4 >>size
+ read4 >>reserved
+ read4 >>offset ;
+
+: parse-bitmap-header ( bitmap -- bitmap )
+ read4 >>header-length
+ read4 >>width
+ read4 >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>size-image
+ read4 >>x-pels
+ read4 >>y-pels
+ read4 >>color-used
+ read4 >>color-important ;
: rgb-quads-length ( bitmap -- n )
- [ offset>> 14 - ] keep header-length>> - ;
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n )
- [ width>> ] keep [ planes>> * ] keep
- [ bit-count>> * 31 + 32 /i 4 * ] keep
- height>> abs * ;
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
-: parse-bitmap ( bitmap -- )
+: parse-bitmap ( bitmap -- bitmap )
dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index drop ;
+ dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap )
binary [
bitmap new
- dup parse-file-header
- dup parse-bitmap-header
- dup parse-bitmap
+ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader
dup raw-bitmap>array >>array ;
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
: save-bitmap ( bitmap path -- )
binary [
- "BM" >byte-array write
- dup array>> length 14 + 40 + 4 >le write
- 0 4 >le write
- 54 4 >le write
-
- 40 4 >le write
- {
- [ width>> 4 >le write ]
- [ height>> 4 >le write ]
- [ planes>> 1 or 2 >le write ]
- [ bit-count>> 24 or 2 >le write ]
- [ compression>> 0 or 4 >le write ]
- [ size-image>> 4 >le write ]
- [ x-pels>> 0 or 4 >le write ]
- [ y-pels>> 0 or 4 >le write ]
- [ color-used>> 0 or 4 >le write ]
- [ color-important>> 0 or 4 >le write ]
- [ rgb-quads>> write ]
- [ color-index>> write ]
- } cleave
+ B{ CHAR: B CHAR: M } write
+ [
+ array>> length 14 + 40 + write4
+ 0 write4
+ 54 write4
+ 40 write4
+ ] [
+ {
+ [ width>> write4 ]
+ [ height>> write4 ]
+ [ planes>> 1 or write2 ]
+ [ bit-count>> 24 or write2 ]
+ [ compression>> 0 or write4 ]
+ [ size-image>> write4 ]
+ [ x-pels>> 0 or write4 ]
+ [ y-pels>> 0 or write4 ]
+ [ color-used>> 0 or write4 ]
+ [ color-important>> 0 or write4 ]
+ [ rgb-quads>> write ]
+ [ color-index>> write ]
+ } cleave
+ ] bi
] with-file-writer ;
-
-M: bitmap draw-image ( bitmap -- )
- dup height>> 0 < [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- ] [
- 0 over height>> abs glRasterPos2i
- 1.0 1.0 glPixelZoom
- ] if
- [ width>> ] keep
- [
- [ height>> abs ] keep
- bit-count>> {
- { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
- { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
- } case
- ] keep array>> glDrawPixels ;
-
-M: bitmap width ( bitmap -- ) width>> ;
-M: bitmap height ( bitmap -- ) height>> ;
-
-: bitmap. ( path -- )
- load-bitmap <graphics-gadget> gadget. ;
-
-: bitmap-window ( path -- gadget )
- load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
-
-: test-bitmap24 ( -- )
- "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
-
-: test-bitmap8 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
-
-: test-bitmap4 ( -- )
- "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
-
-: test-bitmap1 ( -- )
- "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
-
diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor
index 0533ffaf5d..8e0b1ec43c 100644
--- a/extra/graphics/viewer/viewer.factor
+++ b/extra/graphics/viewer/viewer.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces opengl
-ui.gadgets ui.render accessors ;
+USING: accessors arrays combinators graphics.bitmap kernel math
+math.functions namespaces opengl opengl.gl ui ui.gadgets
+ui.gadgets.panes ui.render ;
IN: graphics.viewer
TUPLE: graphics-gadget < gadget image ;
@@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- )
: <graphics-gadget> ( bitmap -- gadget )
\ graphics-gadget new-gadget
swap >>image ;
+
+M: bitmap draw-image ( bitmap -- )
+ dup height>> 0 < [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ ] [
+ 0 over height>> abs glRasterPos2i
+ 1.0 1.0 glPixelZoom
+ ] if
+ [ width>> ] keep
+ [
+ [ height>> abs ] keep
+ bit-count>> {
+ { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
+ { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ } case
+ ] keep array>> glDrawPixels ;
+
+M: bitmap width ( bitmap -- ) width>> ;
+M: bitmap height ( bitmap -- ) height>> ;
+
+: bitmap. ( path -- )
+ load-bitmap <graphics-gadget> gadget. ;
+
+: bitmap-window ( path -- gadget )
+ load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
From 4adef7db09688f341283c2081b87faa0cd4b40da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 02:45:21 -0600
Subject: [PATCH 03/16] Fix functors bug where changing a hand-written method
into one generated by a functor would forget the method; also associate
functor-generated methods with the source file they're in. Add DEFINES-CLASS,
to parallel DEFINES. Update math.blas and specialized-arrays/vectors to use
DEFINES-CLASS where appropriate
---
basis/functors/functors-tests.factor | 51 +++++++++++++++++--
basis/functors/functors.factor | 11 ++--
basis/math/blas/matrices/matrices.factor | 2 +-
basis/math/blas/vectors/vectors.factor | 2 +-
.../direct/functor/functor.factor | 2 +-
.../specialized-arrays/functor/functor.factor | 2 +-
.../functor/functor.factor | 2 +-
7 files changed, 60 insertions(+), 12 deletions(-)
diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor
index a5f3042b38..df008d52bd 100644
--- a/basis/functors/functors-tests.factor
+++ b/basis/functors/functors-tests.factor
@@ -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
\ No newline at end of file
+[ 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
\ No newline at end of file
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index f4d35b6932..14151692f0 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -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
diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor
index 7b03ddf42a..d9653fca6f 100755
--- a/basis/math/blas/matrices/matrices.factor
+++ b/basis/math/blas/matrices/matrices.factor
@@ -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{
diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor
index 3b7f89f730..4e61f4478e 100755
--- a/basis/math/blas/vectors/vectors.factor
+++ b/basis/math/blas/vectors/vectors.factor
@@ -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
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index ce23186fc6..0c3999db44 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -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 ]
diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index 9a56346be4..3c2c53db31 100644
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -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}
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 2410cc284e..9d48a9e79e 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -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}{
From 7bb0e78314e21b1094cbbc3aaa1cd766f5100e0e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:02:00 -0600
Subject: [PATCH 04/16] Add support for C99 complex float and complex double
types to FFI They are named complex-float and complex-double in the Factor
world
---
basis/alien/arrays/arrays.factor | 17 ++++++++---------
basis/alien/c-types/c-types-docs.factor | 2 ++
basis/alien/structs/structs.factor | 11 +++++++++--
basis/compiler/codegen/codegen.factor | 4 ++--
basis/compiler/tests/alien.factor | 7 +++++++
vm/ffi_test.c | 6 +++++-
vm/ffi_test.h | 2 ++
vm/master.h | 1 +
8 files changed, 36 insertions(+), 14 deletions(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index 727492edb1..c823b614d9 100644
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -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 f ;
+
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 ] ;
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index a2b555b057..dc29ea9bb3 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -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
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 42923fb28b..d9ed53d0c6 100644
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -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 )
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 71d9c36412..d915b29ae5 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -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
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 1b21e40bac..b1a9853d55 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -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
\ No newline at end of file
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index 1ec41ac2b9..36147795d1 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -1,6 +1,5 @@
/* This file is linked into the runtime for the sole purpose
* of testing FFI code. */
-#include <stdio.h>
#include "master.h"
#include "ffi_test.h"
@@ -303,3 +302,8 @@ struct test_struct_14 ffi_test_44(void)
retval.x2 = 2.0;
return retval;
}
+
+complex float ffi_test_45(complex float x, complex double y)
+{
+ return x + 2 * y;
+}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index 7c51261157..de48d6dc5b 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -88,3 +88,5 @@ struct test_struct_16 { float x; int a; };
DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();
+
+complex float ffi_test_45(complex float x, complex double y);
diff --git a/vm/master.h b/vm/master.h
index 86b5223eaa..01b2335841 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -8,6 +8,7 @@
#include <fcntl.h>
#include <limits.h>
#include <math.h>
+#include <complex.h>
#include <stdbool.h>
#include <setjmp.h>
From 7ffbbb13e0ffc533ab7086966cbca975f4f2866d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:36:17 -0600
Subject: [PATCH 05/16] Specialized arrays can now be passed to alien functions
directly, without calling underlying>> first
---
basis/alien/arrays/arrays.factor | 2 +-
basis/alien/c-types/c-types.factor | 9 +++++----
core/alien/alien.factor | 10 +++++++++-
3 files changed, 15 insertions(+), 6 deletions(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index c823b614d9..8253d9458c 100644
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -28,7 +28,7 @@ M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop f ;
-M: array c-type-unboxer-quot drop f ;
+M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: value-type c-type-reg-class drop int-regs ;
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index d1354cb04e..ff9d4cefc4 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -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
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index c97e36e889..93d1a8e306 100644
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays init ;
@@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
+GENERIC: >c-ptr ( obj -- c-ptr )
+
+M: c-ptr >c-ptr ;
+
+SLOT: underlying
+
+M: object >c-ptr underlying>> ;
+
GENERIC: expired? ( c-ptr -- ? ) flushable
M: alien expired? expired>> ;
From d6aa376ed089ce44364ba47693ab32c7f60c9e28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:37:28 -0600
Subject: [PATCH 06/16] Removing now-redundant underlying>> calls
---
basis/cocoa/messages/messages.factor | 2 +-
basis/cocoa/views/views.factor | 2 +-
basis/compiler/tests/alien.factor | 4 ++--
basis/db/postgresql/lib/lib.factor | 6 +++---
basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +-
.../io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +-
.../io/backend/unix/multiplexers/select/select.factor | 4 ++--
basis/io/launcher/windows/windows.factor | 4 ++--
basis/io/pipes/unix/unix.factor | 2 +-
basis/libc/libc.factor | 4 ++--
basis/opengl/opengl.factor | 10 +++++-----
basis/opengl/shaders/shaders.factor | 2 +-
.../specialized-arrays/specialized-arrays-tests.factor | 7 ++++++-
basis/struct-arrays/struct-arrays-tests.factor | 4 ++--
basis/unix/utilities/utilities.factor | 4 ++--
basis/windows/com/wrapper/wrapper.factor | 2 +-
basis/windows/dinput/constants/constants.factor | 2 +-
basis/x11/clipboard/clipboard.factor | 2 +-
basis/x11/glx/glx.factor | 2 +-
basis/x11/xim/xim.factor | 2 +-
20 files changed, 37 insertions(+), 32 deletions(-)
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index ebe98a2df1..a0b0e89a0d 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -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 -- )
diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor
index 03cafd0a0a..e74e912202 100644
--- a/basis/cocoa/views/views.factor
+++ b/basis/cocoa/views/views.factor
@@ -68,7 +68,7 @@ PRIVATE>
NSOpenGLPFASamples , 8 ,
] when
0 ,
- ] int-array{ } make underlying>>
+ ] int-array{ } make
-> initWithAttributes:
-> autorelease ;
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index b1a9853d55..b9c62f1429 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -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
diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor
index 19cf5c5002..05114a4deb 100644
--- a/basis/db/postgresql/lib/lib.factor
+++ b/basis/db/postgresql/lib/lib.factor
@@ -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 )
[
diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor
index a91f62f1df..e1428fee4d 100644
--- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor
+++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor
@@ -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 -- )
diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
index 2a6648981b..7bd157136a 100644
--- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
+++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
@@ -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 -- )
diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor
index c62101e478..7d0acb4140 100644
--- a/basis/io/backend/unix/multiplexers/select/select.factor
+++ b/basis/io/backend/unix/multiplexers/select/select.factor
@@ -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 -- )
diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor
index 0497754aa2..7de6c25a13 100755
--- a/basis/io/launcher/windows/windows.factor
+++ b/basis/io/launcher/windows/windows.factor
@@ -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 ;
diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor
index 6a0015084b..f94733ca56 100644
--- a/basis/io/pipes/unix/unix.factor
+++ b/basis/io/pipes/unix/unix.factor
@@ -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 ;
diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
index c4d351e6a0..1e751833a2 100644
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@@ -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 ;
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index f5868ee7a1..6d9ac95965 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -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 ;
diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor
index eb5bbb0ee8..a77d29da2f 100755
--- a/basis/opengl/shaders/shaders.factor
+++ b/basis/opengl/shaders/shaders.factor
@@ -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
diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor
index 1ca041191e..73e719b806 100644
--- a/basis/specialized-arrays/specialized-arrays-tests.factor
+++ b/basis/specialized-arrays/specialized-arrays-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor
index 6f77e66cd2..a8ce98888c 100755
--- a/basis/struct-arrays/struct-arrays-tests.factor
+++ b/basis/struct-arrays/struct-arrays-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor
index e2f780cd13..29b137e3de 100644
--- a/basis/unix/utilities/utilities.factor
+++ b/basis/unix/utilities/utilities.factor
@@ -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 ;
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index 813d8315ac..c86cde23d9 100755
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -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 ;
diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor
index 0e9a03f075..314fb167e3 100755
--- a/basis/windows/dinput/constants/constants.factor
+++ b/basis/windows/dinput/constants/constants.factor
@@ -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 )
diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor
index d3fe0a8447..8375636a72 100644
--- a/basis/x11/clipboard/clipboard.factor
+++ b/basis/x11/clipboard/clipboard.factor
@@ -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 -- )
diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor
index e0b786ce7d..11473d6e83 100644
--- a/basis/x11/glx/glx.factor
+++ b/basis/x11/glx/glx.factor
@@ -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* ;
diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor
index 856420af0f..534e47ac37 100644
--- a/basis/x11/xim/xim.factor
+++ b/basis/x11/xim/xim.factor
@@ -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 ;
From 242638fc5c20a70cd96a3dd770ed097fb3327824 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:38:31 -0600
Subject: [PATCH 07/16] alien.complex vocabulary implementing support for C99
complex numbers
---
basis/alien/complex/authors.txt | 1 +
basis/alien/complex/complex-tests.factor | 18 ++++++++++
basis/alien/complex/complex.factor | 6 ++++
basis/alien/complex/functor/authors.txt | 1 +
.../complex/functor/functor-tests.factor | 4 +++
basis/alien/complex/functor/functor.factor | 35 +++++++++++++++++++
basis/alien/complex/summary.txt | 1 +
7 files changed, 66 insertions(+)
create mode 100644 basis/alien/complex/authors.txt
create mode 100644 basis/alien/complex/complex-tests.factor
create mode 100644 basis/alien/complex/complex.factor
create mode 100644 basis/alien/complex/functor/authors.txt
create mode 100644 basis/alien/complex/functor/functor-tests.factor
create mode 100644 basis/alien/complex/functor/functor.factor
create mode 100644 basis/alien/complex/summary.txt
diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/alien/complex/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor
new file mode 100644
index 0000000000..bfb2c1137c
--- /dev/null
+++ b/basis/alien/complex/complex-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor
new file mode 100644
index 0000000000..60a84b9394
--- /dev/null
+++ b/basis/alien/complex/complex.factor
@@ -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 >>
\ No newline at end of file
diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/alien/complex/functor/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor
new file mode 100644
index 0000000000..c2df22be1d
--- /dev/null
+++ b/basis/alien/complex/functor/functor-tests.factor
@@ -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
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
new file mode 100644
index 0000000000..1d12bb0ff4
--- /dev/null
+++ b/basis/alien/complex/functor/functor.factor
@@ -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
\ No newline at end of file
diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt
new file mode 100644
index 0000000000..76c00c1d65
--- /dev/null
+++ b/basis/alien/complex/summary.txt
@@ -0,0 +1 @@
+Implementation details for C99 complex float and complex double types
From 3166828f755bb8e2a0a1c0d4e34e880210cda393 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:38:54 -0600
Subject: [PATCH 08/16] Fix bug reported by Doug: smart combinators and inline
words didn't mix very well in some cases
---
basis/combinators/smart/smart-tests.factor | 8 ++++
.../transforms/transforms-tests.factor | 15 ++++++
.../transforms/transforms.factor | 46 ++++++-------------
3 files changed, 38 insertions(+), 31 deletions(-)
diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 370dc26960..69a3a821e5 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 8ae30dcd97..2e2dccd6c4 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -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
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 808ea6a141..e5c2f05d72 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -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 ]
From f9bc9a31981a415c5d26cdf01b529fa1fa5ef4c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 04:53:08 -0600
Subject: [PATCH 09/16] Fix VM compile error
---
vm/math.c | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/vm/math.c b/vm/math.c
index f0aa874886..7bff0de387 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -530,8 +530,8 @@ void box_double(double flo)
void primitive_from_rect(void)
{
- F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
- complex->imaginary = dpop();
- complex->real = dpop();
- dpush(RETAG(complex,COMPLEX_TYPE));
+ F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
+ z->imaginary = dpop();
+ z->real = dpop();
+ dpush(RETAG(z,COMPLEX_TYPE));
}
From 5579de1722a1490a45a6e069069aafd5420fdac0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 05:09:10 -0600
Subject: [PATCH 10/16] Fix load error in graphics.bitmap tests
---
extra/graphics/bitmap/bitmap-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor
index 4998427b22..15e960084a 100644
--- a/extra/graphics/bitmap/bitmap-tests.factor
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@@ -1,4 +1,4 @@
-USING: graphics.bitmap ;
+USING: graphics.bitmap graphics.viewer ;
IN: graphics.bitmap.tests
: test-bitmap24 ( -- )
From 33b513fb0538ce9946d861f2b853095a54b0cef0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:16:51 -0600
Subject: [PATCH 11/16] byte-length on f outputs 0
---
basis/alien/c-types/c-types.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index ff9d4cefc4..cf5daa1562 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -178,6 +178,8 @@ GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
+M: f byte-length drop 0 ;
+
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
From 79bb003e6dce8d346032de749f26c791e5be56a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:17:20 -0600
Subject: [PATCH 12/16] io.sockets.secure.openssl: Don't allocate empty
password string. Fixes test failures introduced by >c-ptr change
---
basis/io/sockets/secure/openssl/openssl.factor | 12 +++++++-----
1 file changed, 7 insertions(+), 5 deletions(-)
diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor
index 0326969e4f..f78f61ef3b 100644
--- a/basis/io/sockets/secure/openssl/openssl.factor
+++ b/basis/io/sockets/secure/openssl/openssl.factor
@@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ;
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
- [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
- [
- [ handle>> ] [ default-pasword ] bi
- SSL_CTX_set_default_passwd_cb_userdata
- ] bi ;
+ dup config>> password>> [
+ [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
+ [
+ [ handle>> ] [ default-pasword ] bi
+ SSL_CTX_set_default_passwd_cb_userdata
+ ] bi
+ ] [ drop ] if ;
: use-private-key-file ( ctx -- )
dup config>> key-file>> [
From 53758074a29aa3b5c85ede92199705ee11db2433 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:21:55 -0600
Subject: [PATCH 13/16] stack-checker: do constant folding for curry and
compose with constant inputs at compile time. Allows macros to expand in more
cases, fixing the fry caveat found by Doug
---
.../known-words/known-words.factor | 53 ++++++++-----------
basis/stack-checker/stack-checker-docs.factor | 8 ---
.../stack-checker/stack-checker-tests.factor | 5 ++
.../transforms/transforms-docs.factor | 13 +++--
.../transforms/transforms-tests.factor | 9 ++++
.../transforms/transforms.factor | 4 +-
basis/stack-checker/values/values.factor | 30 +++++++++--
7 files changed, 73 insertions(+), 49 deletions(-)
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 7cdce301b5..56aebb20e7 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -89,44 +89,37 @@ M: composed infer-call*
M: object infer-call*
\ literal-expected inference-warning ;
-: infer-slip ( -- )
- 1 infer->r infer-call 1 infer-r> ;
+: infer-nslip ( n -- )
+ [ infer->r infer-call ] [ infer-r> ] bi ;
-: infer-2slip ( -- )
- 2 infer->r infer-call 2 infer-r> ;
+: infer-slip ( -- ) 1 infer-nslip ;
-: infer-3slip ( -- )
- 3 infer->r infer-call 3 infer-r> ;
+: infer-2slip ( -- ) 2 infer-nslip ;
-: infer-dip ( -- )
- literals get
- [ \ dip def>> infer-quot-here ]
- [ pop 1 infer->r infer-quot-here 1 infer-r> ]
+: infer-3slip ( -- ) 3 infer-nslip ;
+
+: infer-ndip ( word n -- )
+ [ literals get ] 2dip
+ [ '[ _ def>> infer-quot-here ] ]
+ [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi*
if-empty ;
-: infer-2dip ( -- )
- literals get
- [ \ 2dip def>> infer-quot-here ]
- [ pop 2 infer->r infer-quot-here 2 infer-r> ]
- if-empty ;
+: infer-dip ( -- ) \ dip 1 infer-ndip ;
-: infer-3dip ( -- )
- literals get
- [ \ 3dip def>> infer-quot-here ]
- [ pop 3 infer->r infer-quot-here 3 infer-r> ]
- if-empty ;
+: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
-: infer-curry ( -- )
- 2 consume-d
- dup first2 <curried> make-known
- [ push-d ] [ 1array ] bi
- \ curry #call, ;
+: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
-: infer-compose ( -- )
- 2 consume-d
- dup first2 <composed> make-known
- [ push-d ] [ 1array ] bi
- \ compose #call, ;
+: infer-builder ( quot word -- )
+ [
+ [ 2 consume-d ] dip
+ [ dup first2 ] dip call make-known
+ [ push-d ] [ 1array ] bi
+ ] dip #call, ; inline
+
+: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
+
+: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
: infer-execute ( -- )
pop-literal nip
diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index 5b67cd9adc..5926f08d8c 100644
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -80,13 +80,6 @@ $nl
"[ [ 5 ] t foo ] infer."
} ;
-ARTICLE: "compiler-transforms" "Compiler transforms"
-"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time."
-{ $subsection define-transform }
-"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "."
-$nl
-"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
-
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
@@ -103,7 +96,6 @@ $nl
{ $subsection "inference-recursive-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-errors" }
-{ $subsection "compiler-transforms" }
{ $see-also "effects" } ;
ABOUT: "inference"
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 4d7295042c..bc6eb9f092 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -577,3 +577,8 @@ DEFER: eee'
[ bogus-error ] must-infer
[ [ clear ] infer. ] [ inference-error? ] must-fail-with
+
+: debugging-curry-folding ( quot -- )
+ [ debugging-curry-folding ] curry call ; inline recursive
+
+[ [ ] debugging-curry-folding ] must-infer
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor
index a178669595..de0edc4528 100644
--- a/basis/stack-checker/transforms/transforms-docs.factor
+++ b/basis/stack-checker/transforms/transforms-docs.factor
@@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ;
HELP: define-transform
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
-{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." }
-{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:"
-{ $code ": ndrop ( n -- ) [ drop ] times ;" }
-"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:"
-{ $code "\\ ndrop [ \\ drop <repetition> >quotation ] 1 define-transform" }
-"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "."
+{ $description "Defines a compiler transform for the optimizing compiler."
+ "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "."
$nl
-"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
+"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect."
+$nl
+"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." }
+{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 2e2dccd6c4..fe580084c0 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- )
[ [ "a" "b" "c" ] very-smart-combo ] must-infer
[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
+
+! Caveat found by Doug
+DEFER: curry-folding-test ( quot -- )
+
+\ curry-folding-test [ length \ drop <repetition> >quotation ] 1 define-transform
+
+{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
+{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index e5c2f05d72..a2f616480a 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -24,8 +24,10 @@ IN: stack-checker.transforms
rstate infer-quot
] [ word give-up-transform ] if* ;
+: literals? ( values -- ? ) [ literal-value? ] all? ;
+
: (apply-transform) ( word quot n -- )
- ensure-d dup [ known literal? ] all? [
+ ensure-d dup literals? [
dup empty? [ dup recursive-state get ] [
[ ]
[ [ literal value>> ] map ]
diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor
index 97aa774e55..19db441381 100644
--- a/basis/stack-checker/values/values.factor
+++ b/basis/stack-checker/values/values.factor
@@ -26,27 +26,51 @@ SYMBOL: known-values
: copy-values ( values -- values' )
[ copy-value ] map ;
+GENERIC: (literal-value?) ( value -- ? )
+
+M: object (literal-value?) drop f ;
+
+GENERIC: (literal) ( value -- literal )
+
! Literal value
TUPLE: literal < identity-tuple value recursion hashcode ;
+: literal ( value -- literal ) known (literal) ;
+
+: literal-value? ( value -- ? ) known (literal-value?) ;
+
M: literal hashcode* nip hashcode>> ;
: <literal> ( obj -- value )
recursive-state get over hashcode \ literal boa ;
-GENERIC: (literal) ( value -- literal )
+M: literal (literal-value?) drop t ;
M: literal (literal) ;
-: literal ( value -- literal )
- known (literal) ;
+: curried/composed-literal ( input1 input2 quot -- literal )
+ [ [ literal ] bi@ ] dip
+ [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
+ over hashcode \ literal boa ; inline
! Result of curry
TUPLE: curried obj quot ;
C: <curried> curried
+: >curried< ( curried -- obj quot )
+ [ obj>> ] [ quot>> ] bi ; inline
+
+M: curried (literal-value?) >curried< [ literal-value? ] both? ;
+M: curried (literal) >curried< [ curry ] curried/composed-literal ;
+
! Result of compose
TUPLE: composed quot1 quot2 ;
C: <composed> composed
+
+: >composed< ( composed -- quot1 quot2 )
+ [ quot1>> ] [ quot2>> ] bi ; inline
+
+M: composed (literal-value?) >composed< [ literal-value? ] both? ;
+M: composed (literal) >composed< [ compose ] curried/composed-literal ;
\ No newline at end of file
From d1486589efc44be2c58277597dc37e84f70c4017 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:22:09 -0600
Subject: [PATCH 14/16] Improving macro docs
---
basis/macros/macros-docs.factor | 45 ++++++++++++++++++++++++++-------
basis/macros/macros.factor | 4 +++
core/kernel/kernel-docs.factor | 17 +++++++------
3 files changed, 49 insertions(+), 17 deletions(-)
diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor
index 704cae459a..acd2c3383f 100644
--- a/basis/macros/macros-docs.factor
+++ b/basis/macros/macros-docs.factor
@@ -1,27 +1,54 @@
-USING: help.markup help.syntax quotations kernel ;
+USING: help.markup help.syntax quotations kernel
+stack-checker.transforms sequences ;
IN: macros
HELP: MACRO:
{ $syntax "MACRO: word ( inputs... -- ) definition... ;" }
-{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "."
-$nl
-"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect."
-}
+{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." }
{ $notes
- "Semantically, the following two definitions are equivalent:"
+ "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:"
+ { $list
+ { "All inputs to the macro call are literal" }
+ { "The word calling the macro has a static stack effect" }
+ { "The expansion quotation produced by the macro has a static stack effect" }
+ }
+ "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time."
+ $nl
+ "Other than possible compile-time expansion, the following two definition styles are equivalent:"
{ $code "MACRO: foo ... ;" }
{ $code ": foo ... call ;" }
- "However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost."
+ "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation."
+}
+{ $examples
+ "A macro that calls a quotation but preserves any values it consumes off the stack:"
+ { $code
+ "USING: fry generalizations ;"
+ "MACRO: preserving ( quot -- )"
+ " [ infer in>> length ] keep '[ _ ndup @ ] ;"
+ }
+ "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:"
+ { $code
+ ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline"
+ }
+ "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand."
+ $nl
+ "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language."
} ;
HELP: macro
{ $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ;
ARTICLE: "macros" "Macros"
-"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code."
+"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances."
+$nl
+"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code."
+$nl
+"Factor macros are similar to Lisp macros; they are not like C preprocessor macros."
$nl
"Defining new macros:"
{ $subsection POSTPONE: MACRO: }
-"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ;
+"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
+{ $subsection define-transform }
+"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
ABOUT: "macros"
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index 1481e6eea5..4fba7efba3 100644
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors ;
IN: macros
+<PRIVATE
+
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
+PRIVATE>
+
: define-macro ( word definition -- )
[ "macro" set-word-prop ]
[ over real-macro-effect memoize-quot [ call ] append define ]
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index d85a51edff..71183093ee 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions"
{ $subsection assert }
{ $subsection assert= } ;
+ARTICLE: "dataflow-combinators" "Data flow combinators"
+"Data flow combinators pass values between quotations:"
+{ $subsection "slip-keep-combinators" }
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" } ;
+
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
@@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-$nl
-"Data flow combinators:"
-{ $subsection "slip-keep-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
-"Control flow combinators:"
+{ $subsection "dataflow-combinators" }
{ $subsection "conditionals" }
{ $subsection "looping-combinators" }
-"Additional combinators:"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
@@ -973,6 +973,7 @@ $nl
"Advanced topics:"
{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
+{ $subsection "macros" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
From 31f976e0e909aff88f122cde1de0e7bb381969fa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 10:22:22 -0600
Subject: [PATCH 15/16] pack: cleanup, write macros in more intuitive style
that works now
---
basis/pack/pack.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor
index aec4414c71..3cf7dbab4c 100755
--- a/basis/pack/pack.factor
+++ b/basis/pack/pack.factor
@@ -113,9 +113,7 @@ CONSTANT: packed-length-table
MACRO: pack ( str -- quot )
[ pack-table at '[ _ execute ] ] { } map-as
- '[ _ spread ]
- '[ _ input<sequence ]
- '[ _ B{ } append-outputs-as ] ;
+ '[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
PRIVATE>
@@ -143,7 +141,7 @@ MACRO: unpack ( str -- quot )
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
- '[ _ cleave ] '[ _ output>array ] ;
+ '[ [ _ cleave ] output>array ] ;
PRIVATE>
From 05632b85254fe0bc5968ae934d3629049a2f7f78 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 6 Feb 2009 11:03:52 -0600
Subject: [PATCH 16/16] Don't use complex.h since *BSDs don't have it in latest
release versions (gah!); add DLLEXPORT for ffi_test_45 to make it work on
Windows
---
vm/ffi_test.c | 2 +-
vm/ffi_test.h | 2 +-
vm/master.h | 1 -
3 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index 36147795d1..c7a9f7d890 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -303,7 +303,7 @@ struct test_struct_14 ffi_test_44(void)
return retval;
}
-complex float ffi_test_45(complex float x, complex double y)
+_Complex float ffi_test_45(_Complex float x, _Complex double y)
{
return x + 2 * y;
}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index de48d6dc5b..42ab8d71d1 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -89,4 +89,4 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();
-complex float ffi_test_45(complex float x, complex double y);
+DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y);
diff --git a/vm/master.h b/vm/master.h
index 01b2335841..86b5223eaa 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -8,7 +8,6 @@
#include <fcntl.h>
#include <limits.h>
#include <math.h>
-#include <complex.h>
#include <stdbool.h>
#include <setjmp.h>