From a9c13e03017da324a8130729256e31f9395ad657 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 16 Feb 2010 22:19:56 -0800
Subject: [PATCH 01/20] fix last globs test on windows
---
basis/globs/globs-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
mode change 100644 => 100755 basis/globs/globs-tests.factor
diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor
old mode 100644
new mode 100755
index c9903b1633..b2432754b1
--- a/basis/globs/globs-tests.factor
+++ b/basis/globs/globs-tests.factor
@@ -30,7 +30,7 @@ IN: globs.tests
[ t ] [ "fo\\*" glob-pattern? ] unit-test
[ t ] [ "fo{o,bro}" glob-pattern? ] unit-test
-"foo" "bar" append-path 1array
+{ "foo" "bar" } path-separator join 1array
[ { "foo" "bar" "ba?" } path-separator join glob-parent-directory ] unit-test
[ "foo" ]
From a64d6e27ecc0a1b3673277aedbdc3a981a9f91a2 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 16 Feb 2010 22:31:21 -0800
Subject: [PATCH 02/20] move alut stuff to openal.alut so alut only gets
deployed if we use it
---
extra/morse/morse.factor | 2 +-
extra/openal/alut/alut.factor | 103 ++++++++++++++++++
extra/openal/{ => alut}/backend/authors.txt | 0
.../openal/{ => alut}/backend/backend.factor | 2 +-
extra/openal/{ => alut}/macosx/authors.txt | 0
extra/openal/{ => alut}/macosx/macosx.factor | 4 +-
extra/openal/{ => alut}/macosx/tags.txt | 0
extra/openal/{ => alut}/other/authors.txt | 0
extra/openal/{ => alut}/other/other.factor | 4 +-
extra/openal/example/example.factor | 2 +-
extra/openal/openal.factor | 95 +---------------
extra/space-invaders/space-invaders.factor | 1 +
extra/synth/example/example.factor | 2 +-
extra/synth/synth.factor | 2 +-
14 files changed, 115 insertions(+), 102 deletions(-)
mode change 100644 => 100755 extra/morse/morse.factor
create mode 100755 extra/openal/alut/alut.factor
rename extra/openal/{ => alut}/backend/authors.txt (100%)
rename extra/openal/{ => alut}/backend/backend.factor (79%)
mode change 100644 => 100755
rename extra/openal/{ => alut}/macosx/authors.txt (100%)
rename extra/openal/{ => alut}/macosx/macosx.factor (84%)
mode change 100644 => 100755
rename extra/openal/{ => alut}/macosx/tags.txt (100%)
rename extra/openal/{ => alut}/other/authors.txt (100%)
rename extra/openal/{ => alut}/other/other.factor (89%)
mode change 100644 => 100755
mode change 100644 => 100755 extra/openal/example/example.factor
mode change 100644 => 100755 extra/openal/openal.factor
mode change 100644 => 100755 extra/space-invaders/space-invaders.factor
mode change 100644 => 100755 extra/synth/example/example.factor
mode change 100644 => 100755 extra/synth/synth.factor
diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor
old mode 100644
new mode 100755
index cbe3c0f2fa..c6f1601955
--- a/extra/morse/morse.factor
+++ b/extra/morse/morse.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal openal.alut parser sequences splitting strings synth synth.buffers ;
IN: morse
ERROR: no-morse-ch ch ;
diff --git a/extra/openal/alut/alut.factor b/extra/openal/alut/alut.factor
new file mode 100755
index 0000000000..d1b8d2600d
--- /dev/null
+++ b/extra/openal/alut/alut.factor
@@ -0,0 +1,103 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors arrays alien system combinators
+alien.syntax namespaces alien.c-types sequences vocabs.loader
+shuffle openal openal.alut.backend alien.libraries generalizations
+specialized-arrays alien.destructors ;
+FROM: alien.c-types => float short ;
+SPECIALIZED-ARRAY: uint
+IN: openal.alut
+
+<< "alut" {
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
+ } cond "cdecl" add-library >>
+
+<< os macosx? [ "alut" deploy-library ] unless >>
+
+LIBRARY: alut
+
+CONSTANT: ALUT_API_MAJOR_VERSION 1
+CONSTANT: ALUT_API_MINOR_VERSION 1
+CONSTANT: ALUT_ERROR_NO_ERROR 0
+CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
+CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
+CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
+CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
+CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
+CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
+CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
+CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
+CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
+CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
+CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
+CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
+CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
+CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
+CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
+CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
+CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
+CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
+CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
+CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
+CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
+CONSTANT: ALUT_LOADER_BUFFER HEX: 300
+CONSTANT: ALUT_LOADER_MEMORY HEX: 301
+
+FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutExit ( ) ;
+FUNCTION: ALenum alutGetError ( ) ;
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
+FUNCTION: ALint alutGetMajorVersion ( ) ;
+FUNCTION: ALint alutGetMinorVersion ( ) ;
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
+
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
+
+SYMBOL: init
+
+: init-openal ( -- )
+ init get-global expired? [
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
+ 1337 <alien> init set-global
+ ] when ;
+
+: exit-openal ( -- )
+ init get-global expired? [
+ alutExit 0 = [ "Could not close OpenAL" throw ] when
+ f init set-global
+ ] unless ;
+
+: create-buffer-from-file ( filename -- buffer )
+ alutCreateBufferFromFile dup AL_NONE = [
+ "create-buffer-from-file failed" throw
+ ] when ;
+
+os macosx? "openal.alut.macosx" "openal.alut.other" ? require
+
+: create-buffer-from-wav ( filename -- buffer )
+ gen-buffer dup rot load-wav-file
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
+
+: check-error ( -- )
+ alGetError dup ALUT_ERROR_NO_ERROR = [
+ drop
+ ] [
+ alGetString throw
+ ] if ;
+
diff --git a/extra/openal/backend/authors.txt b/extra/openal/alut/backend/authors.txt
similarity index 100%
rename from extra/openal/backend/authors.txt
rename to extra/openal/alut/backend/authors.txt
diff --git a/extra/openal/backend/backend.factor b/extra/openal/alut/backend/backend.factor
old mode 100644
new mode 100755
similarity index 79%
rename from extra/openal/backend/backend.factor
rename to extra/openal/alut/backend/backend.factor
index 41069dcddf..fc50d3d15e
--- a/extra/openal/backend/backend.factor
+++ b/extra/openal/alut/backend/backend.factor
@@ -1,4 +1,4 @@
USING: namespaces system ;
-IN: openal.backend
+IN: openal.alut.backend
HOOK: load-wav-file os ( filename -- format data size frequency )
diff --git a/extra/openal/macosx/authors.txt b/extra/openal/alut/macosx/authors.txt
similarity index 100%
rename from extra/openal/macosx/authors.txt
rename to extra/openal/alut/macosx/authors.txt
diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/alut/macosx/macosx.factor
old mode 100644
new mode 100755
similarity index 84%
rename from extra/openal/macosx/macosx.factor
rename to extra/openal/alut/macosx/macosx.factor
index f0a6b928e9..3c0a4672cb
--- a/extra/openal/macosx/macosx.factor
+++ b/extra/openal/alut/macosx/macosx.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-openal openal.backend namespaces system generalizations ;
-IN: openal.macosx
+openal openal.alut.backend namespaces system generalizations ;
+IN: openal.alut.macosx
LIBRARY: alut
diff --git a/extra/openal/macosx/tags.txt b/extra/openal/alut/macosx/tags.txt
similarity index 100%
rename from extra/openal/macosx/tags.txt
rename to extra/openal/alut/macosx/tags.txt
diff --git a/extra/openal/other/authors.txt b/extra/openal/alut/other/authors.txt
similarity index 100%
rename from extra/openal/other/authors.txt
rename to extra/openal/alut/other/authors.txt
diff --git a/extra/openal/other/other.factor b/extra/openal/alut/other/other.factor
old mode 100644
new mode 100755
similarity index 89%
rename from extra/openal/other/other.factor
rename to extra/openal/alut/other/other.factor
index ada8d6b1fb..b19579286b
--- a/extra/openal/other/other.factor
+++ b/extra/openal/alut/other/other.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators generalizations
-kernel openal openal.backend ;
-IN: openal.other
+kernel openal openal.alut.backend ;
+IN: openal.alut.other
LIBRARY: alut
diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor
old mode 100644
new mode 100755
index 4d979a8fa7..7789ee6e0a
--- a/extra/openal/example/example.factor
+++ b/extra/openal/example/example.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar kernel openal sequences threads ;
+USING: calendar kernel openal openal.alut sequences threads ;
IN: openal.example
: play-hello ( -- )
diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor
old mode 100644
new mode 100755
index d3c2b0a5cc..bbe61f9dc3
--- a/extra/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -2,20 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors arrays alien system combinators
alien.syntax namespaces alien.c-types sequences vocabs.loader
-shuffle openal.backend alien.libraries generalizations
+shuffle alien.libraries generalizations
specialized-arrays alien.destructors ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: uint
IN: openal
-<< "alut" {
- { [ os windows? ] [ "alut.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
-
<< "openal" {
{ [ os windows? ] [ "OpenAL32.dll" ] }
{ [ os macosx? ] [
@@ -24,7 +16,7 @@ IN: openal
{ [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
-<< os macosx? [ "openal" deploy-library "alut" deploy-library ] unless >>
+<< os macosx? [ "openal" deploy-library ] unless >>
LIBRARY: openal
@@ -254,71 +246,6 @@ FUNCTION: void alcCaptureSamples ( ALCdevice* device, void* buf, ALCsizei samps
DESTRUCTOR: alcCloseDevice*
DESTRUCTOR: alcDestroyContext
-LIBRARY: alut
-
-CONSTANT: ALUT_API_MAJOR_VERSION 1
-CONSTANT: ALUT_API_MINOR_VERSION 1
-CONSTANT: ALUT_ERROR_NO_ERROR 0
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301
-
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutExit ( ) ;
-FUNCTION: ALenum alutGetError ( ) ;
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
-FUNCTION: ALint alutGetMajorVersion ( ) ;
-FUNCTION: ALint alutGetMinorVersion ( ) ;
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
-
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
-
-SYMBOL: init
-
-: init-openal ( -- )
- init get-global expired? [
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
- 1337 <alien> init set-global
- ] when ;
-
-: exit-openal ( -- )
- init get-global expired? [
- alutExit 0 = [ "Could not close OpenAL" throw ] when
- f init set-global
- ] unless ;
-
: gen-sources ( size -- seq )
dup <uint-array> [ alGenSources ] keep ;
@@ -327,17 +254,6 @@ SYMBOL: init
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
-: create-buffer-from-file ( filename -- buffer )
- alutCreateBufferFromFile dup AL_NONE = [
- "create-buffer-from-file failed" throw
- ] when ;
-
-os macosx? "openal.macosx" "openal.other" ? require
-
-: create-buffer-from-wav ( filename -- buffer )
- gen-buffer dup rot load-wav-file
- [ alBufferData ] 4 nkeep alutUnloadWAV ;
-
: queue-buffers ( source buffers -- )
[ length ] [ >uint-array ] bi alSourceQueueBuffers ;
@@ -360,12 +276,5 @@ os macosx? "openal.macosx" "openal.other" ? require
: source-stop ( source -- ) alSourceStop ;
-: check-error ( -- )
- alGetError dup ALUT_ERROR_NO_ERROR = [
- drop
- ] [
- alGetString throw
- ] if ;
-
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
old mode 100644
new mode 100755
index 17e277fb6a..01bf621769
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -18,6 +18,7 @@ USING:
math
math.order
openal
+ openal.alut
opengl.gl
sequences
ui
diff --git a/extra/synth/example/example.factor b/extra/synth/example/example.factor
old mode 100644
new mode 100755
index 747cfb9c86..e09d903afb
--- a/extra/synth/example/example.factor
+++ b/extra/synth/example/example.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces make openal sequences
+USING: accessors arrays kernel namespaces make openal openal.alut sequences
synth synth.buffers ;
IN: synth.example
diff --git a/extra/synth/synth.factor b/extra/synth/synth.factor
old mode 100644
new mode 100755
index def610d356..90645e3562
--- a/extra/synth/synth.factor
+++ b/extra/synth/synth.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+USING: accessors kernel locals math math.constants math.functions memoize openal openal.alut synth.buffers sequences sequences.modified sequences.repeating ;
IN: synth
MEMO: single-sine-wave ( samples/wave -- seq )
From da7cd4186ab0a9e70709fdaa5514d5c4d647b24a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 01:18:48 +1300
Subject: [PATCH 03/20] help.markup: make $example render slightly nicer
---
basis/help/markup/markup.factor | 4 ++--
basis/help/stylesheet/stylesheet.factor | 7 +++++--
2 files changed, 7 insertions(+), 4 deletions(-)
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 75e6538243..f951f30b2f 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -129,8 +129,8 @@ ALIAS: $slot $snippet
"Examples" $heading print-element ;
: $example ( element -- )
- 1 cut* swap "\n" join dup <input> [
- input-style get format nl print-element
+ 1 cut* [ "\n" join ] bi@ over <input> [
+ [ print ] [ output-style get format ] bi*
] ($code) ;
: $unchecked-example ( element -- )
diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor
index 8a119823cc..d5b783fef8 100644
--- a/basis/help/stylesheet/stylesheet.factor
+++ b/basis/help/stylesheet/stylesheet.factor
@@ -80,8 +80,11 @@ H{
{ wrap-margin f }
} code-style set-global
-SYMBOL: input-style
-H{ { font-style bold } } input-style set-global
+SYMBOL: output-style
+H{
+ { font-style bold }
+ { foreground COLOR: dark-red }
+} output-style set-global
SYMBOL: url-style
H{
From 36cff8ed6e8ff8900ac2bf99d70db97033ea55f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 01:19:26 +1300
Subject: [PATCH 04/20] combinators: better wrong-values error
---
core/combinators/combinators.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 95b62fc3f3..9016d540d7 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -17,7 +17,7 @@ M: object throw
PRIVATE>
-ERROR: wrong-values quot effect ;
+ERROR: wrong-values quot call-site ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in
From 63928191e719c041624300c37e9e855c550a2b46 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 01:19:39 +1300
Subject: [PATCH 05/20] Minor documentation fixes
---
basis/listener/listener-docs.factor | 28 ++++++++++++++++++++--------
core/generic/generic-docs.factor | 8 +++++++-
2 files changed, 27 insertions(+), 9 deletions(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index 77bec12c1a..a35f43e848 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -1,8 +1,8 @@
-USING: help.markup help.syntax kernel io system prettyprint continuations quotations ;
+USING: help.markup help.syntax kernel io system prettyprint continuations quotations vocabs.loader vocabs.refresh parser ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
-"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
+"The listener prints values of dynamic variables which are added to a watch list:"
{ $subsections visible-vars }
"To add or remove a single variable:"
{ $subsections
@@ -14,7 +14,7 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
show-vars
hide-vars
}
-"Hiding all visible variables:"
+"Clearing the watch list:"
{ $subsections hide-all-vars } ;
HELP: only-use-vocabs
@@ -46,21 +46,33 @@ HELP: hide-all-vars
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
-"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
+"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link refresh-all } " or " { $link run-file } ", and then test it from interactively."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
+"New words can also be defined in the listener:"
+{ $example
+ "USE: math.functions"
+ ": twice ( word -- ) [ execute ] [ execute ] bi ; inline"
+ "81 \\ sqrt twice ."
+ "3"
+}
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
-"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
+"The listener will display the current contents of the datastack after every line of input."
$nl
-"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:"
+"The listener can watch dynamic variables:"
{ $subsections "listener-watch" }
-"To start a nested listener:"
+"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:"
+{ $code
+ "USING: db db.sqlite listener ;"
+ "\"data.db\" <sqlite-db> [ listener ] with-db"
+}
+"Starting a nested listener:"
{ $subsections listener }
"To exit a listener, invoke the " { $link return } " word."
$nl
-"Multi-line quotations can be read independently of the rest of the listener:"
+"The listener's mechanism for reading multi-line expressions from the input stream can be called from user code:"
{ $subsections read-quot } ;
ABOUT: "listener"
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 3a9314fb56..8d4f1f61a5 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -166,7 +166,13 @@ HELP: create-method
HELP: (call-next-method)
{ $values { "method" method } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
-{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
+{ $notes
+ "The " { $link POSTPONE: call-next-method } " word parses into this word. The following are equivalent:"
+ { $code
+ "M: class generic call-next-method ;"
+ "M: class generic M\\ class generic (call-next-method) ;"
+ }
+} ;
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
From 41433da61bb490011d62acff99cdc34711cf44c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 01:57:22 +1300
Subject: [PATCH 06/20] core: minor cleanups
---
core/arrays/arrays.factor | 14 +++-----------
core/combinators/combinators.factor | 4 ++++
2 files changed, 7 insertions(+), 11 deletions(-)
diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor
index fa4d4b2f69..62a0774444 100644
--- a/core/arrays/arrays.factor
+++ b/core/arrays/arrays.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
@@ -9,24 +9,16 @@ M: array length length>> ; inline
M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
M: array resize resize-array ; inline
-
-: >array ( seq -- array ) { } clone-like ;
-
+M: array equal? over array? [ sequence= ] [ 2drop f ] if ;
M: object new-sequence drop 0 <array> ; inline
-
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
-M: array equal?
- over array? [ sequence= ] [ 2drop f ] if ;
-
INSTANCE: array sequence
+: >array ( seq -- array ) { } clone-like ;
: 1array ( x -- array ) 1 swap <array> ; inline
-
: 2array ( x y -- array ) { } 2sequence ; inline
-
: 3array ( x y z -- array ) { } 3sequence ; inline
-
: 4array ( w x y z -- array ) { } 4sequence ; inline
PREDICATE: pair < array length 2 number= ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 9016d540d7..7b9481825b 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -5,6 +5,10 @@ kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order make ;
IN: combinators
+! Most of these combinators have compile-time expansions in
+! the optimizing compiler. See stack-checker.transforms and
+! compiler.tree.propagation.call-effect
+
<PRIVATE
: call-effect-unsafe ( quot effect -- ) drop call ;
From 01824d41be4f631118fdc4c94de180cdfc21ac6c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 02:19:57 +1300
Subject: [PATCH 07/20] Add support for final tuple classes which cannot be
subclassed: TUPLE: foo ... ; final
---
basis/classes/struct/struct-tests.factor | 25 +++++++++++++++++-----
basis/classes/struct/struct.factor | 4 +---
basis/debugger/debugger.factor | 2 +-
basis/functors/functors.factor | 3 +++
basis/typed/typed-tests.factor | 8 +++++++
core/bootstrap/syntax.factor | 1 +
core/classes/parser/parser.factor | 3 ++-
core/classes/tuple/tuple-tests.factor | 27 ++++++++++++++++++++++++
core/classes/tuple/tuple.factor | 12 +++++++++--
core/syntax/syntax.factor | 4 ++++
10 files changed, 77 insertions(+), 12 deletions(-)
diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index 2c0db93522..cb7e4ee2b0 100644
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -1,11 +1,11 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
-assocs byte-arrays classes.struct classes.tuple.private
+assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
-tools.test parser lexer eval layouts ;
+tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
@@ -338,13 +338,28 @@ STRUCT: struct-that's-a-word { x int } ;
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
-] must-fail
+] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
- "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
-] must-fail
+] [ error>> bad-superclass? ] must-fail-with
+
+! Changing a superclass into a struct should reset the subclass
+TUPLE: will-become-struct ;
+
+TUPLE: a-subclass < will-become-struct ;
+
+[ f ] [ will-become-struct struct-class? ] unit-test
+
+[ will-become-struct ] [ a-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
+
+[ t ] [ will-become-struct struct-class? ] unit-test
+
+[ tuple ] [ a-subclass superclass ] unit-test
! Remove c-type when struct class is forgotten
[ ] [
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index fae39cd229..a5711de609 100644
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -32,8 +32,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
-M: struct-class valid-superclass? drop f ;
-
SLOT: fields
: struct-slots ( struct-class -- slots )
@@ -273,7 +271,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
- [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+ [ struct f define-tuple-class ] [ make-final ] bi ;
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 815304b21f..b6497c52a9 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -194,7 +194,7 @@ M: not-a-tuple summary
drop "Not a tuple" ;
M: bad-superclass summary
- drop "Tuple classes can only inherit from other tuple classes" ;
+ drop "Tuple classes can only inherit from non-final tuple classes" ;
M: no-initial-value summary
drop "Initial value must be provided for slots specialized to this class" ;
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index ac2e52f68e..6678613002 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -63,6 +63,9 @@ FUNCTOR-SYNTAX: TUPLE:
} case
\ define-tuple-class suffix! ;
+FUNCTOR-SYNTAX: final
+ [ word make-final ] append! ;
+
FUNCTOR-SYNTAX: SINGLETON:
scan-param suffix!
\ define-singleton-class suffix! ;
diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor
index f7b853cff7..f1e151b985 100644
--- a/basis/typed/typed-tests.factor
+++ b/basis/typed/typed-tests.factor
@@ -97,3 +97,11 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
buh set ;
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
+
+! Reported by littledan
+TUPLE: superclass x ;
+TUPLE: subclass < superclass y ;
+
+TYPED: unbox-fail ( superclass: a -- ? ) subclass? ;
+
+[ t ] [ subclass new unbox-fail ] unit-test
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index bb159f04df..1870f4ac1b 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -49,6 +49,7 @@ IN: bootstrap.syntax
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
+ "final"
"SLOT:"
"T{"
"UNION:"
diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor
index 8233d8cff3..41ce32105d 100644
--- a/core/classes/parser/parser.factor
+++ b/core/classes/parser/parser.factor
@@ -8,8 +8,9 @@ IN: classes.parser
: create-class-in ( string -- word )
current-vocab create
+ dup set-word
dup save-class-location
- dup create-predicate-word dup set-word save-location ;
+ dup create-predicate-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 36d402c61d..6711c5705e 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -770,3 +770,30 @@ TUPLE: tuple-predicate-redefine-test ;
[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
+
+! Final classes
+TUPLE: final-superclass ;
+TUPLE: final-subclass < final-superclass ;
+
+[ final-superclass ] [ final-subclass superclass ] unit-test
+
+! Making the superclass final should change the superclass of the subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
+
+[ tuple ] [ final-subclass superclass ] unit-test
+
+[ t ] [ \ final-subclass valid-superclass? ] unit-test
+
+! Subclassing a final class should fail
+[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
+[ error>> bad-superclass? ] must-fail-with
+
+! Making a final class non-final should work
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
+
+! Changing a superclass should not change the final status of a subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
+
+[ f ] [ \ final-subclass valid-superclass? ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 363c2879e9..c7a3afdd6d 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -240,7 +240,7 @@ M: tuple-class update-class
GENERIC: valid-superclass? ( class -- ? )
-M: tuple-class valid-superclass? drop t ;
+M: tuple-class valid-superclass? "final" word-prop not ;
M: builtin-class valid-superclass? tuple eq? ;
@@ -266,8 +266,16 @@ PRIVATE>
: define-tuple-class ( class superclass slots -- )
over check-superclass
over prepare-slots
+ pick f "final" set-word-prop
(define-tuple-class) ;
+GENERIC: make-final ( class -- )
+
+M: tuple-class make-final
+ [ dup class-usage keys ?metaclass-changed ]
+ [ t "final" set-word-prop ]
+ bi ;
+
M: word (define-tuple-class)
define-new-tuple-class ;
@@ -301,7 +309,7 @@ M: tuple-class reset-class
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
+ [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
bi
] bi ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index cf2c49fff9..0b5b32e289 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -204,6 +204,10 @@ IN: bootstrap.syntax
parse-tuple-definition define-tuple-class
] define-core-syntax
+ "final" [
+ word make-final
+ ] define-core-syntax
+
"SLOT:" [
scan define-protocol-slot
] define-core-syntax
From 60296be9641543c403098cf7f1b2cd5d9dbaa84a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 02:39:12 +1300
Subject: [PATCH 08/20] typed: only unbox final classes. Fixes bug reported by
littledan
---
.../dependencies/dependencies.factor | 12 +++++-
basis/typed/typed-tests.factor | 37 ++++++++++++++-----
basis/typed/typed.factor | 12 ++++--
core/classes/tuple/tuple.factor | 27 +++++++++-----
4 files changed, 64 insertions(+), 24 deletions(-)
diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor
index d995354a52..df68fa8961 100644
--- a/basis/stack-checker/dependencies/dependencies.factor
+++ b/basis/stack-checker/dependencies/dependencies.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors classes.algebra fry generic kernel math
-namespaces sequences words sets combinators.short-circuit ;
+namespaces sequences words sets combinators.short-circuit
+classes.tuple ;
FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
@@ -122,6 +123,15 @@ TUPLE: depends-on-flushable word ;
M: depends-on-flushable satisfied?
word>> flushable? ;
+TUPLE: depends-on-final class ;
+
+: depends-on-final ( word -- )
+ [ depends-on-conditionally ]
+ [ \ depends-on-final add-conditional-dependency ] bi ;
+
+M: depends-on-final satisfied?
+ class>> final-class? ;
+
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor
index f1e151b985..7f984ccaf2 100644
--- a/basis/typed/typed-tests.factor
+++ b/basis/typed/typed-tests.factor
@@ -14,8 +14,8 @@ TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
most-positive-fixnum neg 1 - 1quotation
[ most-positive-fixnum 1 fix+ ] unit-test
-TUPLE: tweedle-dee ;
-TUPLE: tweedle-dum ;
+TUPLE: tweedle-dee ; final
+TUPLE: tweedle-dum ; final
TYPED: dee ( x: tweedle-dee -- y )
drop \ tweedle-dee ;
@@ -39,11 +39,11 @@ TYPED:: f+locals ( a: float b: float -- c: float )
TUPLE: unboxable
{ x fixnum read-only }
- { y fixnum read-only } ;
+ { y fixnum read-only } ; final
TUPLE: unboxable2
{ u unboxable read-only }
- { xy fixnum read-only } ;
+ { xy fixnum read-only } ; final
TYPED: unboxy ( in: unboxable -- out: unboxable2 )
dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
@@ -63,7 +63,7 @@ IN: typed.tests
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only }
- { z float read-only } ;
+ { z float read-only } ; final
""" eval( -- )
"""
@@ -79,13 +79,15 @@ TYPED: no-inputs ( -- out: integer )
[ 1 ] [ no-inputs ] unit-test
TUPLE: unboxable3
- { x read-only } ;
+ { x read-only } ; final
TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
T{ unboxable3 } ;
[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
+[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
+
SYMBOL: buh
TYPED: no-outputs ( x: integer -- )
@@ -98,10 +100,25 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
-! Reported by littledan
-TUPLE: superclass x ;
-TUPLE: subclass < superclass y ;
+[ f ] [
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ eq?
+] unit-test
-TYPED: unbox-fail ( superclass: a -- ? ) subclass? ;
+! Reported by littledan
+TUPLE: superclass { x read-only } ;
+TUPLE: subclass < superclass { y read-only } ; final
+
+TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
[ t ] [ subclass new unbox-fail ] unit-test
+
+! If a final class becomes non-final, typed words need to be recompiled
+TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
+
+[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
+
+[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor
index e71196e3ee..8a85ca1afb 100644
--- a/basis/typed/typed.factor
+++ b/basis/typed/typed.factor
@@ -20,6 +20,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
{
[ all-slots empty? not ]
[ immutable-tuple-class? ]
+ [ final-class? ]
} 1&& ;
! typed inputs
@@ -30,9 +31,14 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: input-mismatch-quot ( word types -- quot )
[ input-mismatch-error ] 2curry ;
+: depends-on-unboxing ( class -- )
+ [ dup tuple-layout depends-on-tuple-layout ]
+ [ depends-on-final ]
+ bi ;
+
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
@@ -52,7 +58,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [ class>> (unboxed-types) ] map concat
]
[ 1array ] if ;
@@ -81,7 +87,7 @@ DEFER: make-boxer
: boxer ( type -- quot )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
[ all-slots [ class>> ] map make-boxer ]
[ [ boa ] curry ]
bi compose
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index c7a3afdd6d..b590826511 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -93,6 +93,14 @@ ERROR: bad-superclass class ;
] [ 2drop f ] if
] [ 2drop f ] if ; inline
+GENERIC: final-class? ( class -- ? )
+
+M: tuple-class final-class? "final" word-prop ;
+
+M: builtin-class final-class? tuple eq? not ;
+
+M: class final-class? drop t ;
+
<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
@@ -238,16 +246,8 @@ M: tuple-class update-class
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
-GENERIC: valid-superclass? ( class -- ? )
-
-M: tuple-class valid-superclass? "final" word-prop not ;
-
-M: builtin-class valid-superclass? tuple eq? ;
-
-M: class valid-superclass? drop f ;
-
: check-superclass ( superclass -- )
- dup valid-superclass? [ bad-superclass ] unless drop ;
+ dup final-class? [ bad-superclass ] when drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
@@ -261,12 +261,19 @@ GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
read-only suffix
] map ;
+: reset-final ( class -- )
+ dup final-class? [
+ [ f "final" set-word-prop ]
+ [ changed-conditionally ]
+ bi
+ ] [ drop ] if ;
+
PRIVATE>
: define-tuple-class ( class superclass slots -- )
over check-superclass
over prepare-slots
- pick f "final" set-word-prop
+ pick reset-final
(define-tuple-class) ;
GENERIC: make-final ( class -- )
From ff172f4132b3938e3aa83df3d5da0b973fd9e096 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 02:39:40 +1300
Subject: [PATCH 09/20] Make specialized arrays and SIMD types final so that
typed can unbox them
---
basis/math/vectors/simd/simd.factor | 2 +-
basis/sequences/cords/cords.factor | 6 +++---
basis/specialized-arrays/specialized-arrays.factor | 2 +-
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor
index acf13599c1..a60026317d 100644
--- a/basis/math/vectors/simd/simd.factor
+++ b/basis/math/vectors/simd/simd.factor
@@ -251,7 +251,7 @@ BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
-TUPLE: A < simd-128 ;
+TUPLE: A < simd-128 ; final
M: A new-underlying drop \ A boa ; inline
M: A simd-rep drop A-rep ; inline
diff --git a/basis/sequences/cords/cords.factor b/basis/sequences/cords/cords.factor
index fca005fa6e..4a2d267a12 100644
--- a/basis/sequences/cords/cords.factor
+++ b/basis/sequences/cords/cords.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
math.order arrays classes combinators kernel functors math.functions
@@ -8,7 +8,7 @@ IN: sequences.cords
MIXIN: cord
TUPLE: generic-cord
- { head read-only } { tail read-only } ;
+ { head read-only } { tail read-only } ; final
INSTANCE: generic-cord cord
M: cord length
@@ -34,7 +34,7 @@ T-cord DEFINES-CLASS ${C}
WHERE
TUPLE: T-cord
- { head T read-only } { tail T read-only } ;
+ { head T read-only } { tail T read-only } ; final
INSTANCE: T-cord cord
M: T cord-append
diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor
index eda793ff22..d3db93e788 100644
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -47,7 +47,7 @@ WHERE
TUPLE: A
{ underlying c-ptr read-only }
-{ length array-capacity read-only } ;
+{ length array-capacity read-only } ; final
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
From c4c14c7cebeac1adc48d00ead76fad8bcac299b9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:00:43 +1300
Subject: [PATCH 10/20] classes.tuple: fix screwup
---
core/classes/tuple/tuple.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index b590826511..64c34d221a 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -273,7 +273,6 @@ PRIVATE>
: define-tuple-class ( class superclass slots -- )
over check-superclass
over prepare-slots
- pick reset-final
(define-tuple-class) ;
GENERIC: make-final ( class -- )
@@ -287,6 +286,7 @@ M: word (define-tuple-class)
define-new-tuple-class ;
M: tuple-class (define-tuple-class)
+ pick reset-final
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
From 9df8a3adbd5362ec6d8674a29440f984a5c48537 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:01:26 +1300
Subject: [PATCH 11/20] see: show final declaration on tuples
---
basis/prettyprint/prettyprint-tests.factor | 12 ++++++++++++
basis/see/see.factor | 21 ++++++++++++++-------
2 files changed, 26 insertions(+), 7 deletions(-)
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 8ba6e94a49..ec0e20a393 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -362,3 +362,15 @@ TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
] [
[ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test
+
+TUPLE: final-tuple ; final
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: final-tuple ; final"
+ ""
+ }
+] [
+ [ \ final-tuple see ] with-string-writer "\n" split
+] unit-test
diff --git a/basis/see/see.factor b/basis/see/see.factor
index 0d2388114a..326e051219 100644
--- a/basis/see/see.factor
+++ b/basis/see/see.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate classes.singleton
@@ -182,14 +182,21 @@ M: array pprint-slot-name
dup length 1 = [ first ] when
pprint-slot-name ;
+: tuple-declarations. ( class -- )
+ \ final declaration. ;
+
+: superclass. ( class -- )
+ superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
- dup pprint-word
- dup superclass tuple eq? [
- "<" text dup superclass pprint-word
- ] unless
- <block "slots" word-prop [ pprint-slot ] each block>
- pprint-; block> ;
+ {
+ [ pprint-word ]
+ [ superclass. ]
+ [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
+ [ tuple-declarations. ]
+ } cleave
+ block> ;
M: word see-class* drop ;
From d2ae4ff4bada2584fbde4a486f5da1712e2d99ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:36:43 +1300
Subject: [PATCH 12/20] listener: fix docs
---
basis/listener/listener-docs.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index a35f43e848..bb20fe62ae 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax kernel io system prettyprint continuations quotations vocabs.loader vocabs.refresh parser ;
+USING: help.markup help.syntax kernel io system prettyprint
+continuations quotations vocabs.loader parser ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
@@ -46,7 +47,7 @@ HELP: hide-all-vars
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
-"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link refresh-all } " or " { $link run-file } ", and then test it from interactively."
+"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link reload } " or " { $link run-file } ", and then test it from interactively."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
From 4b76e2a61dc933ea39d4431d076bb9f47e94f883 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:56:41 +1300
Subject: [PATCH 13/20] functors: make 'final' declarations work in functors
---
basis/functors/backend/backend.factor | 10 ++++--
basis/functors/functors-tests.factor | 47 +++++++++++++++++++++++++--
basis/functors/functors.factor | 2 +-
3 files changed, 52 insertions(+), 7 deletions(-)
diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor
index dd3d891f7b..331864417e 100644
--- a/basis/functors/backend/backend.factor
+++ b/basis/functors/backend/backend.factor
@@ -1,6 +1,6 @@
USING: accessors arrays assocs generic.standard kernel
lexer locals.types namespaces parser quotations vocabs.parser
-words ;
+words classes.tuple ;
IN: functors.backend
DEFER: functor-words
@@ -27,7 +27,11 @@ SYNTAX: FUNCTOR-SYNTAX:
: define* ( word def -- ) over set-word define ;
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
+: define-declared* ( word def effect -- )
+ pick set-word define-declared ;
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+: define-simple-generic* ( word effect -- )
+ over set-word define-simple-generic ;
+: define-tuple-class* ( class superclass slots -- )
+ pick set-word define-tuple-class ;
diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor
index 544c2ed1e4..c756d1b83d 100644
--- a/basis/functors/functors-tests.factor
+++ b/basis/functors/functors-tests.factor
@@ -1,5 +1,5 @@
-USING: classes.struct functors tools.test math words kernel
-multiline parser io.streams.string generic ;
+USING: classes.struct classes.tuple functors tools.test math
+words kernel multiline parser io.streams.string generic ;
QUALIFIED-WITH: alien.c-types c
IN: functors.tests
@@ -36,7 +36,7 @@ WW DEFINES ${W}${W}
WHERE
-: WW ( a -- b ) \ W twice ; inline
+: WW ( a -- b ) \ W twice ;
;FUNCTOR
@@ -211,3 +211,44 @@ STRUCT: T-class
}
] [ a-struct struct-slots ] unit-test
+<<
+
+FUNCTOR: define-an-inline-word ( W -- )
+
+W DEFINES ${W}
+W-W DEFINES ${W}-${W}
+
+WHERE
+
+: W ( -- ) ; inline
+: W-W ( -- ) W W ;
+
+;FUNCTOR
+
+"an-inline-word" define-an-inline-word
+
+>>
+
+[ t ] [ \ an-inline-word inline? ] unit-test
+[ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test
+
+<<
+
+FUNCTOR: define-a-final-class ( T W -- )
+
+T DEFINES-CLASS ${T}
+W DEFINES ${W}
+
+WHERE
+
+TUPLE: T ; final
+
+: W ( -- ) ;
+
+;FUNCTOR
+
+"a-final-tuple" "a-word" define-a-final-class
+
+>>
+
+[ t ] [ a-final-tuple final-class? ] unit-test
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 6678613002..1895c6e0f4 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -61,7 +61,7 @@ FUNCTOR-SYNTAX: TUPLE:
make suffix!
]
} case
- \ define-tuple-class suffix! ;
+ \ define-tuple-class* suffix! ;
FUNCTOR-SYNTAX: final
[ word make-final ] append! ;
From 049b87bda9b71f5e29d6aa804285e7b31ec9f5bd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:57:02 +1300
Subject: [PATCH 14/20] tuple-arrays: require that base type be final
---
basis/tuple-arrays/tuple-arrays-docs.factor | 12 ++++++----
basis/tuple-arrays/tuple-arrays-tests.factor | 22 ++++++++++++++-----
basis/tuple-arrays/tuple-arrays.factor | 15 +++++++++++--
.../tuple-arrays/tuple-arrays.factor | 4 ++--
4 files changed, 40 insertions(+), 13 deletions(-)
diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor
index 5e70e15aa7..72a5ae4df3 100644
--- a/basis/tuple-arrays/tuple-arrays-docs.factor
+++ b/basis/tuple-arrays/tuple-arrays-docs.factor
@@ -3,20 +3,24 @@ USING: help.markup help.syntax sequences ;
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
+{ $values { "class" "a final tuple class" } }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
-"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of references to heap-allocated objects, a tuple array stores its elements as values."
$nl
-"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
+"Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+$nl
+"Since value semantics are incompatible with inheritance, the base type of a tuple array must be declared " { $link POSTPONE: final } ". A best practice that is not enforced is to have all slots in the tuple declared " { $link read-only } "."
+$nl
+"Tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
$nl
-"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsections POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
- "TUPLE: point x y ;"
+ "TUPLE: point x y ; final"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"
diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor
index 2eeae20aa1..0fbf0eeaa0 100644
--- a/basis/tuple-arrays/tuple-arrays-tests.factor
+++ b/basis/tuple-arrays/tuple-arrays-tests.factor
@@ -1,9 +1,9 @@
USING: tuple-arrays sequences tools.test namespaces kernel
-math accessors ;
+math accessors classes.tuple eval ;
IN: tuple-arrays.tests
SYMBOL: mat
-TUPLE: foo bar ;
+TUPLE: foo bar ; final
C: <foo> foo
TUPLE-ARRAY: foo
@@ -18,15 +18,27 @@ TUPLE-ARRAY: foo
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
-TUPLE: baz { bing integer } bong ;
+TUPLE: baz { bing integer } bong ; final
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
-TUPLE: broken x ;
+TUPLE: broken x ; final
: broken ( -- ) ;
TUPLE-ARRAY: broken
-[ 100 ] [ 100 <broken-array> length ] unit-test
\ No newline at end of file
+[ 100 ] [ 100 <broken-array> length ] unit-test
+
+! Can't define a tuple array for a non-tuple class
+[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ]
+[ error>> not-a-tuple? ]
+must-fail-with
+
+! Can't define a tuple array for a non-final class
+TUPLE: non-final x ;
+
+[ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ]
+[ error>> not-final? ]
+must-fail-with
\ No newline at end of file
diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor
index aea51f7820..1a3091c1e2 100644
--- a/basis/tuple-arrays/tuple-arrays.factor
+++ b/basis/tuple-arrays/tuple-arrays.factor
@@ -1,11 +1,13 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
-stack-checker parser math classes.tuple.private ;
+stack-checker parser math classes.tuple classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
+ERROR: not-final class ;
+
<PRIVATE
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
@@ -29,6 +31,13 @@ MACRO: write-tuple ( class -- quot )
[ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
+: check-final ( class -- )
+ {
+ { [ dup tuple-class? not ] [ not-a-tuple ] }
+ { [ dup final-class? not ] [ not-final ] }
+ [ drop ]
+ } cond ;
+
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
@@ -43,6 +52,8 @@ CLASS-array? IS ${CLASS-array}?
WHERE
+CLASS check-final
+
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }
diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor
index 701db77135..80c31553c1 100644
--- a/extra/benchmark/tuple-arrays/tuple-arrays.factor
+++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor
@@ -1,10 +1,10 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions tuple-arrays accessors fry sequences
prettyprint ;
IN: benchmark.tuple-arrays
-TUPLE: point { x float } { y float } { z float } ;
+TUPLE: point { x float } { y float } { z float } ; final
TUPLE-ARRAY: point
From bf72c890603b00757f0ea8334888908b52af9e34 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 03:57:10 +1300
Subject: [PATCH 15/20] tools.deploy.backend: clean up
---
basis/tools/deploy/backend/backend.factor | 11 +++++------
1 file changed, 5 insertions(+), 6 deletions(-)
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index fe63071998..9f25808c9e 100644
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
@@ -19,13 +19,12 @@ TUPLE: vocab-manifest vocabs libraries ;
: copy-resources ( manifest name dir -- )
append-path swap vocabs>> [ copy-vocab-resources ] with each ;
-ERROR: cant-deploy-library-file library ;
-<PRIVATE
+ERROR: can't-deploy-library-file library ;
+
: copy-library ( dir library -- )
dup find-library-file
- [ nip swap over file-name append-path copy-file ]
- [ cant-deploy-library-file ] if* ;
-PRIVATE>
+ [ swap over file-name append-path copy-file ]
+ [ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
From 9debed1c75490b451c7268a7a3043b3e184a6fee Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 04:13:21 +1300
Subject: [PATCH 16/20] typed: update documentation
---
basis/typed/typed-docs.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/basis/typed/typed-docs.factor b/basis/typed/typed-docs.factor
index 0b6838379c..c6f80a48bc 100644
--- a/basis/typed/typed-docs.factor
+++ b/basis/typed/typed-docs.factor
@@ -58,10 +58,18 @@ HELP: output-mismatch-error
ARTICLE: "typed" "Strongly-typed word definitions"
"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
+$nl
+"Parameters and return values of typed words where the type is declared to be a " { $link POSTPONE: final } " tuple class with all slots " { $link read-only } " are passed by value."
{ $subsections
POSTPONE: TYPED:
POSTPONE: TYPED::
+}
+"Defining typed words at run time:"
+{ $subsections
define-typed
+}
+"Errors:"
+{ $subsections
input-mismatch-error
output-mismatch-error
} ;
From c5259f2e2c54fb44642d322b7fc6bb5836bc99b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 04:13:34 +1300
Subject: [PATCH 17/20] classes.tuple: document final class declaration
---
core/classes/tuple/tuple-docs.factor | 5 +++++
core/syntax/syntax-docs.factor | 4 ++++
2 files changed, 9 insertions(+)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 2b3e80da1d..7f6078e321 100644
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -191,6 +191,8 @@ $nl
"tuple-inheritance-example"
"tuple-inheritance-anti-example"
}
+"Declaring a tuple class final prohibits other classes from subclassing it:"
+{ $subsections POSTPONE: final }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
@@ -441,3 +443,6 @@ HELP: boa
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
+
+HELP: bad-superclass
+{ $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link POSTPONE: final } "." } ;
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 8ad6084188..4a1af4c578 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -792,6 +792,10 @@ $nl
{ $code "TUPLE: person" "{ age integer initial: 0 }" "{ department string initial: \"Marketing\" }" "manager ;" }
} ;
+HELP: final
+{ $syntax "TUPLE: ... ; final" }
+{ $description "Declares the most recently defined word as a final tuple class which cannot be subclassed. Attempting to subclass a final class raises a " { $link bad-superclass } " error." } ;
+
HELP: initial:
{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
From 31ccfa2e5d8633c7e09aa26754bc3a197daf4860 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 04:58:30 +1300
Subject: [PATCH 18/20] Fix unit test failures
---
core/classes/tuple/tuple-tests.factor | 4 ++--
core/parser/parser-tests.factor | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 6711c5705e..276c6b407c 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -782,7 +782,7 @@ TUPLE: final-subclass < final-superclass ;
[ tuple ] [ final-subclass superclass ] unit-test
-[ t ] [ \ final-subclass valid-superclass? ] unit-test
+[ f ] [ \ final-subclass final-class? ] unit-test
! Subclassing a final class should fail
[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
@@ -796,4 +796,4 @@ TUPLE: final-subclass < final-superclass ;
! Changing a superclass should not change the final status of a subclass
[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
-[ f ] [ \ final-subclass valid-superclass? ] unit-test
+[ t ] [ \ final-subclass final-class? ] unit-test
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index f30eb68684..266a65b957 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -339,7 +339,7 @@ IN: parser.tests
] unit-test
[ t ] [
- "foo?" "parser.tests" lookup word eq?
+ "foo" "parser.tests" lookup word eq?
] unit-test
[ ] [
From 9da061de5eb4d6d45a60a34eef4ca6814f13234c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 18 Feb 2010 07:02:22 +1300
Subject: [PATCH 19/20] listener: fix help lint
---
basis/listener/listener-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index bb20fe62ae..bb014fef62 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -56,7 +56,7 @@ $nl
"USE: math.functions"
": twice ( word -- ) [ execute ] [ execute ] bi ; inline"
"81 \\ sqrt twice ."
- "3"
+ "3.0"
}
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
From 31d97a8ff7cddd6c0a23ca284d5c9c4c5f32112e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 17 Feb 2010 11:26:32 -0800
Subject: [PATCH 20/20] fall back to manual gl vertex attribute management when
GL_APPLE_vertex_array_object is not present, so gpu can support vanilla GL
2.0
---
extra/gpu/gpu.factor | 4 +-
extra/gpu/render/render.factor | 5 +-
extra/gpu/shaders/shaders.factor | 80 ++++++++++++++++++++++++++------
extra/gpu/state/state.factor | 4 --
4 files changed, 71 insertions(+), 22 deletions(-)
mode change 100644 => 100755 extra/gpu/gpu.factor
mode change 100644 => 100755 extra/gpu/render/render.factor
mode change 100644 => 100755 extra/gpu/shaders/shaders.factor
mode change 100644 => 100755 extra/gpu/state/state.factor
diff --git a/extra/gpu/gpu.factor b/extra/gpu/gpu.factor
old mode 100644
new mode 100755
index 6a61e2ec4f..1d02b3f07a
--- a/extra/gpu/gpu.factor
+++ b/extra/gpu/gpu.factor
@@ -9,10 +9,12 @@ TUPLE: gpu-object < identity-tuple handle ;
VARIANT: gpu-api
opengl-2 opengl-3 ;
+SYMBOL: has-vertex-array-objects?
+
: set-gpu-api ( -- )
"2.0" require-gl-version
"3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } }
- require-gl-version-or-extensions
+ has-gl-version-or-extensions? has-vertex-array-objects? set-global
"3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
HOOK: init-gpu-api gpu-api ( -- )
diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor
old mode 100644
new mode 100755
index 1d4813ab54..2b7d75a3ae
--- a/extra/gpu/render/render.factor
+++ b/extra/gpu/render/render.factor
@@ -520,9 +520,6 @@ SYNTAX: UNIFORM-TUPLE:
<PRIVATE
-: bind-vertex-array ( vertex-array -- )
- handle>> glBindVertexArray ;
-
: bind-unnamed-output-attachments ( framebuffer attachments -- )
[ gl-attachment ] with map
dup length 1 =
@@ -567,7 +564,7 @@ UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
TUPLE: render-set
{ primitive-mode primitive-mode read-only }
- { vertex-array vertex-array read-only }
+ { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
{ uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only }
{ instances ?integer initial: f read-only }
diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor
old mode 100644
new mode 100755
index 0401584f7c..025acba896
--- a/extra/gpu/shaders/shaders.factor
+++ b/extra/gpu/shaders/shaders.factor
@@ -2,9 +2,9 @@
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs byte-arrays classes.mixin classes.parser
classes.singleton classes.struct combinators combinators.short-circuit
-definitions destructors fry generic.parser gpu gpu.buffers hashtables
-images io.encodings.ascii io.files io.pathnames kernel lexer
-literals locals math math.parser memoize multiline namespaces
+definitions destructors fry generic.parser gpu gpu.buffers gpu.private
+gpu.state hashtables images io.encodings.ascii io.files io.pathnames
+kernel lexer literals locals math math.parser memoize multiline namespaces
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
@@ -319,11 +319,18 @@ SYNTAX: VERTEX-FORMAT:
SYNTAX: VERTEX-STRUCT:
CREATE-CLASS scan-word define-vertex-struct ;
-TUPLE: vertex-array < gpu-object
+TUPLE: vertex-array-object < gpu-object
{ program-instance program-instance read-only }
{ vertex-buffers sequence read-only } ;
-M: vertex-array dispose
+TUPLE: vertex-array-collection
+ { vertex-formats sequence read-only }
+ { program-instance program-instance read-only } ;
+
+UNION: vertex-array
+ vertex-array-object vertex-array-collection ;
+
+M: vertex-array-object dispose
[ [ delete-vertex-array ] when* f ] change-handle drop ;
: ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
@@ -331,26 +338,73 @@ M: vertex-array dispose
: ?>buffer ( buffer/ptr -- buffer )
dup buffer? [ buffer>> ] unless ; inline
-:: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+<PRIVATE
+
+: normalize-vertex-formats ( vertex-formats -- vertex-formats' )
+ [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
+
+: (bind-vertex-array) ( vertex-formats program-instance -- )
+ '[ _ swap first2 bind-vertex-format ] each ; inline
+
+: (reset-vertex-array) ( -- )
+ GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
+
+:: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
- vertex-formats [ program-instance swap first2 [ ?>buffer-ptr ] dip bind-vertex-format ] each
- handle program-instance vertex-formats [ first ?>buffer ] map
- vertex-array boa window-resource ; inline
+ vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
-:: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+ handle program-instance vertex-formats [ first ?>buffer ] map
+ vertex-array-object boa window-resource ; inline
+
+: <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
+ [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
+
+:: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
handle program-instance vertex-buffer ?>buffer 1array
- vertex-array boa window-resource ; inline
+ vertex-array-object boa window-resource ; inline
+
+: <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
+ swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
+
+PRIVATE>
+
+GENERIC: bind-vertex-array ( vertex-array -- )
+
+M: vertex-array-object bind-vertex-array
+ handle>> glBindVertexArray ; inline
+
+M: vertex-array-collection bind-vertex-array
+ (reset-vertex-array)
+ [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
+
+: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+ has-vertex-array-objects? get
+ [ <multi-vertex-array-object> ]
+ [ <multi-vertex-array-collection> ] if ; inline
+
+: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+ has-vertex-array-objects? get
+ [ <vertex-array-object> ]
+ [ <vertex-array-collection> ] if ; inline
: <vertex-array> ( vertex-buffer program-instance -- vertex-array )
dup program>> vertex-formats>> first <vertex-array*> ; inline
-TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
- vertex-buffers>> first ;
+GENERIC: vertex-array-buffers ( vertex-array -- buffers )
+
+M: vertex-array-object vertex-array-buffers
+ vertex-buffers>> ; inline
+
+M: vertex-array-collection vertex-array-buffers
+ vertex-formats>> [ first buffer>> ] map ; inline
+
+: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
+ vertex-array-buffers first ; inline
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;
diff --git a/extra/gpu/state/state.factor b/extra/gpu/state/state.factor
old mode 100644
new mode 100755
index 3064ed4b82..db76774038
--- a/extra/gpu/state/state.factor
+++ b/extra/gpu/state/state.factor
@@ -415,8 +415,6 @@ M: mask-state set-gpu-state*
[ [ set-gpu-state* ] each ]
[ set-gpu-state* ] if ; inline
-<PRIVATE
-
: get-gl-bool ( enum -- value )
0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
: get-gl-int ( enum -- value )
@@ -437,8 +435,6 @@ M: mask-state set-gpu-state*
: gl-enabled? ( enum -- ? )
glIsEnabled c-bool> ;
-PRIVATE>
-
TYPED: get-viewport-state ( -- viewport-state: viewport-state )
GL_VIEWPORT get-gl-rect <viewport-state> ;