From a390fe9644f2555c5b47445136113569fb68a8cc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 21:23:47 -0400
Subject: [PATCH] Revert "merge"
This reverts commit c2a03d259a7b853b586afd68a0b842140188e0db.
---
basis/game-input/dinput/dinput.factor | 19 ++++++++-------
basis/io/servers/connection/connection.factor | 23 +++++++------------
core/bootstrap/syntax.factor | 1 +
core/classes/tuple/parser/parser-tests.factor | 10 +++++++-
core/classes/tuple/tuple.factor | 19 +++++++++++----
core/slots/slots.factor | 15 ++++++++++--
core/syntax/syntax.factor | 4 +++-
7 files changed, 57 insertions(+), 34 deletions(-)
diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 8540907db9..0ecf543baa 100755
--- a/basis/game-input/dinput/dinput.factor
+++ b/basis/game-input/dinput/dinput.factor
@@ -1,14 +1,13 @@
-USING: windows.dinput windows.dinput.constants parser
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math alien alien.strings
-io.encodings.utf16 io.encodings.utf16n continuations
-byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors struct-arrays
-math.bitwise ;
+USING: accessors alien alien.c-types alien.strings arrays
+assocs byte-arrays combinators continuations game-input
+game-input.dinput.keys-array io.encodings.utf16
+io.encodings.utf16n kernel locals math math.bitwise
+math.rectangles namespaces parser sequences shuffle
+struct-arrays ui.backend.windows vectors windows.com
+windows.dinput windows.dinput.constants windows.errors
+windows.kernel32 windows.messages windows.ole32
+windows.user32 ;
IN: game-input.dinput
-
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index df6c21e7cc..de75165c7a 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,17 +11,17 @@ combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
-name
-log-level
+{ name initial: "server" }
+{ log-level initial: DEBUG }
secure insecure
-secure-config
-sockets
+{ secure-config initial-quot: [ <secure-config> ] }
+{ sockets initial-quot: [ V{ } clone ] }
max-connections
semaphore
-timeout
+{ timeout initial-quot: [ 1 minutes ] }
encoding
-handler
-ready ;
+{ handler initial: [ "No handler quotation" throw ] }
+{ ready initial-quot: [ <flag> ] } ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@@ -29,14 +29,7 @@ ready ;
: new-threaded-server ( encoding class -- threaded-server )
new
- swap >>encoding
- "server" >>name
- DEBUG >>log-level
- 1 minutes >>timeout
- V{ } clone >>sockets
- <secure-config> >>secure-config
- [ "No handler quotation" throw ] >>handler
- <flag> >>ready ; inline
+ swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index f5182a0210..24538229c6 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,6 +80,7 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
+ "initial-quot:"
"read-only"
"call("
"execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index b95507c78b..350b594274 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
TUPLE: test-1 ;
@@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ;
" x 3 }"
} "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
+
+
+[ ] [
+ <" USE: sequences
+ IN: classes.tuple.tests
+ TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
+ eval( -- )
+] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 225176f4e5..55fbdf725f 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE>
+: initial-value ( slot -- obj )
+ dup initial>> [
+ nip
+ ] [
+ dup initial-quot>> [
+ nip call( -- obj )
+ ] [
+ drop f
+ ] if*
+ ] if* ;
+
: initial-values ( class -- slots )
- all-slots [ initial>> ] map ;
+ all-slots [ initial-value ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
@@ -64,9 +75,7 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-GENERIC: slots>tuple ( seq class -- tuple )
-
-M: tuple-class slots>tuple
+: slots>tuple ( seq class -- tuple )
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
@@ -176,7 +185,7 @@ ERROR: bad-superclass class ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
- [ drop [ initial>> ] map ]
+ [ drop [ initial-value ] map ]
2tri 3array flip ;
: update-slot ( old-values n class initial -- value )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 304ded0adb..9db26846d0 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,10 +3,10 @@
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables summary ;
IN: slots
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
PREDICATE: reader < word "reader" word-prop ;
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
+ { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
@@ -197,7 +198,17 @@ ERROR: bad-slot-attribute key ;
ERROR: bad-initial-value name ;
+ERROR: duplicate-initial-values slot ;
+
+M: duplicate-initial-values summary
+ drop "Slots can either define initial: or initial-quot:, but not both" ;
+
+: check-duplicate-initial-values ( slot-spec -- slot-spec )
+ dup [ initial>> ] [ initial-quot>> ] bi and
+ [ duplicate-initial-values ] when ;
+
: check-initial-value ( slot-spec -- slot-spec )
+ check-duplicate-initial-values
dup initial>> [
[ ] [
dup [ initial>> ] [ class>> ] bi instance?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 56ac9fa36e..8093b6345b 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,7 +245,9 @@ IN: bootstrap.syntax
] define-core-syntax
"initial:" "syntax" lookup define-symbol
-
+
+ "initial-quot:" "syntax" lookup define-symbol
+
"read-only" "syntax" lookup define-symbol
"call(" [ \ call-effect parse-call( ] define-core-syntax