From ec698b7f53fbd5af40a5eef170eb0dc93e243e5d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:43:00 -0500
Subject: [PATCH 1/4] Parser overhaul
---
core/debugger/debugger.factor | 2 +-
core/generic/generic-docs.factor | 13 ++---
core/generic/generic.factor | 54 +++++++------------
core/generic/math/math.factor | 2 +-
core/generic/standard/standard.factor | 4 --
.../specializers/specializers.factor | 36 ++++++++++---
core/parser/parser.factor | 20 +++++--
core/slots/slots.factor | 3 +-
core/syntax/syntax.factor | 19 +++----
core/words/words.factor | 2 +-
extra/delegate/delegate.factor | 2 +-
extra/locals/locals-tests.factor | 19 ++++++-
extra/locals/locals.factor | 20 ++-----
extra/memoize/memoize.factor | 2 +-
extra/multiline/multiline.factor | 2 +-
extra/promises/promises.factor | 2 +-
extra/unicode/data/data.factor | 2 +-
17 files changed, 111 insertions(+), 93 deletions(-)
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 40bcbe78b1..ad2fa14954 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -214,7 +214,7 @@ M: check-closed summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
- drop "Invalid parameters for define-method" ;
+ drop "Invalid parameters for create-method" ;
M: check-tuple summary
drop "Invalid class for define-constructor" ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 9b799d9143..62b85dde3a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -34,7 +34,7 @@ $nl
{ $subsection define-generic }
{ $subsection define-simple-generic }
"Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
@@ -123,7 +123,7 @@ HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@@ -140,16 +140,17 @@ HELP: order
HELP: check-method
{ $values { "class" class } { "generic" generic } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
-HELP: define-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+HELP: create-method
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: implementors
{ $values { "class" class } { "seq" "a sequence of generic words" } }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 3c83b87d49..ad31831e94 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -17,10 +17,6 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
@@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
- ] unless ;
+ ] unless ; inline
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
-: make-method-def ( quot class generic -- quot )
- "combination" word-prop method-prologue swap append ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
+PREDICATE: word method-body
+ "method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
- "method-def" set
] H{ } make-assoc ;
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
check-method
- [ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
- tuck set-word-props
- dup rot define ;
+ [ set-word-props ] keep ;
-: redefine-method ( quot class generic -- )
- [ method swap "method-def" set-word-prop ] 3keep
- [ make-method-def ] 2keep
- method swap define ;
+: reveal-method ( method class generic -- )
+ [ set-at ] with-methods ;
-: define-method ( quot class generic -- )
- >r bootstrap-word r>
- 2dup method [
- redefine-method
+: create-method ( class generic -- method )
+ 2dup method dup [
+ 2nip
] [
- [ <method> ] 2keep
- [ set-at ] with-methods
+ drop [ <method> dup ] 2keep reveal-method
] if ;
+: <default-method> ( generic combination -- method )
+ object bootstrap-word pick <method>
+ [ -rot make-default-method define ] keep ;
+
: define-default-method ( generic combination -- )
- dupd make-default-method object bootstrap-word pick <method>
- "default-method" set-word-prop ;
+ dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
M: method-spec where
@@ -108,11 +98,10 @@ M: method-spec set-where
first2 method set-where ;
M: method-spec definer
- drop \ M: \ ; ;
+ first2 method definer ;
M: method-spec definition
- first2 method dup
- [ "method-def" word-prop ] when ;
+ first2 method definition ;
: forget-method ( class generic -- )
check-method
@@ -125,9 +114,6 @@ M: method-spec forget*
M: method-body definer
drop \ M: \ ; ;
-M: method-body definition
- "method-def" word-prop ;
-
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 27b0ddb7a2..9fd5481a39 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
- [ word-def ]
+ [ 1quotation ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 313f487c99..c634e02e75 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -8,10 +8,6 @@ IN: generic.standard
TUPLE: standard-combination # ;
-M: standard-combination method-prologue
- standard-combination-# object
- <array> swap add* [ declare ] curry ;
-
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 10a9fda3ea..5153d84c7f 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -24,20 +24,40 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
-: specializer-methods ( quot word -- default alist )
+: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
+: method-declaration ( method -- quot )
+ dup "method-generic" word-prop dispatch# object <array>
+ swap "method-class" word-prop add* ;
+
+: specialize-method ( quot method -- quot' )
+ method-declaration [ declare ] curry swap append ;
+
+: specialize-quot ( quot specializer -- quot' )
+ dup { number } = [
+ drop tag-specializer
+ ] [
+ specializer-cases alist>quot
+ ] if ;
+
+: standard-method? ( method -- ? )
+ dup method-body? [
+ "method-generic" word-prop standard-generic?
+ ] [ drop f ] if ;
+
: specialized-def ( word -- quot )
- dup word-def swap "specializer" word-prop [
- dup { number } = [
- drop tag-specializer
- ] [
- specializer-methods alist>quot
- ] if
- ] when* ;
+ dup word-def swap {
+ { [ dup standard-method? ] [ specialize-method ] }
+ {
+ [ dup "specializer" word-prop ]
+ [ "specializer" word-prop specialize-quot ]
+ }
+ { [ t ] [ drop ] }
+ } cond ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 50f8f582d3..c955817ab9 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -215,9 +215,6 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-: create-in ( string -- word )
- in get create dup set-word dup save-location ;
-
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
@@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
+: create-in ( string -- word )
+ in get create dup set-word dup save-location ;
+
: CREATE ( -- word ) scan create-in ;
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
: create-class-in ( word -- word )
in get create
dup save-class-location
@@ -284,6 +288,12 @@ M: no-word summary
] ?if
] when ;
+: create-method-in ( class generic -- method )
+ create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-word create-method-in ;
+
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
@@ -355,7 +365,9 @@ TUPLE: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
GENERIC: expected>string ( obj -- str )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 92d22247bd..7e9046573f 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
- over define-simple-generic -rot define-method ;
+ over define-simple-generic
+ >r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 79a5553228..d9870b08da 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -97,7 +97,7 @@ IN: bootstrap.syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
- CREATE dup reset-generic define-symbol
+ CREATE-WORD define-symbol
] define-syntax
"DEFER:" [
@@ -111,31 +111,26 @@ IN: bootstrap.syntax
] define-syntax
"GENERIC:" [
- CREATE dup reset-word
- define-simple-generic
+ CREATE-GENERIC define-simple-generic
] define-syntax
"GENERIC#" [
- CREATE dup reset-word
+ CREATE-GENERIC
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
- CREATE dup reset-word
+ CREATE-GENERIC
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
- CREATE dup reset-word scan-word
+ CREATE-GENERIC scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
- f set-word
- location >r
- scan-word bootstrap-word scan-word
- [ parse-definition -rot define-method ] 2keep
- 2array r> remember-definition
+ (M:) define
] define-syntax
"UNION:" [
@@ -163,7 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"C:" [
- CREATE dup reset-generic
+ CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax
diff --git a/core/words/words.factor b/core/words/words.factor
index ce69c1ff2e..73b877fdbb 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-def" word-prop ] [ t ] }
+ { [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 654d096b26..9eabfae95c 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -7,7 +7,7 @@ IN: delegate
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
- CREATE dup reset-generic dup define-symbol
+ CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index b4f1b0a61e..bd1e62f22a 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -1,5 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays strings prettyprint ;
+namespaces arrays strings prettyprint io.streams.string parser
+;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ "[| a! | ]" ] [
[| a! | ] unparse
] unit-test
+
+DEFER: xyzzy
+
+[ ] [
+ "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 10 ] [ 10 xyzzy ] unit-test
+
+[ ] [
+ "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 9819e65e37..a8f5e139e7 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -249,13 +249,14 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
-: ((::)) ( word -- word quot )
+: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) ( -- word quot )
- CREATE dup reset-generic ((::)) ;
+: (::) CREATE-WORD parse-locals-definition ;
+
+: (M::) CREATE-METHOD parse-locals-definition ;
PRIVATE>
@@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
: :: (::) define ; parsing
-! This will be cleaned up when method tuples and method words
-! are unified
-: create-method ( class generic -- method )
- 2dup method dup
- [ 2nip ]
- [ drop 2dup [ ] -rot define-method create-method ] if ;
-
-: CREATE-METHOD ( -- class generic body )
- scan-word bootstrap-word scan-word 2dup
- create-method f set-word dup save-location ;
-
-: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
+: M:: (M::) define ; parsing
: MACRO:: (::) define-macro ; parsing
diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor
index 3b0b8fd29f..ab915ae7d5 100755
--- a/extra/memoize/memoize.factor
+++ b/extra/memoize/memoize.factor
@@ -40,7 +40,7 @@ IN: memoize
over make-memoizer define ;
: MEMO:
- CREATE dup reset-generic parse-definition define-memoized ; parsing
+ CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 5baa205d15..079f484274 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -18,7 +18,7 @@ IN: multiline
lexer get next-line ;
: STRING:
- CREATE dup reset-generic
+ CREATE-WORD
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index 3724b929f0..469f6a91ed 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
] [ ] make ;
: LAZY:
- CREATE dup reset-generic
+ CREATE-WORD
dup parse-definition
make-lazy-quot define ; parsing
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 11be803893..d8e1e8937a 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -5,7 +5,7 @@ IN: unicode.data
<<
: VALUE:
- CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;
From bc71849bf665e071a291bfdfbdee9ca031193b86 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:44:17 -0500
Subject: [PATCH 2/4] Fix bogus f variable in global namespace
---
core/threads/threads-tests.factor | 2 ++
core/threads/threads.factor | 2 --
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index c2e627e7bf..d746404cba 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -14,3 +14,5 @@ yield
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
+
+[ f ] [ f get-global ] unit-test
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index b4fd6eee60..d7d7988893 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
: threads 41 getenv ;
-threads global [ H{ } assoc-like ] change-at
-
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
From d06db3f628693ad5d40933cb6ca8b8bf056ba24d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:44:39 -0500
Subject: [PATCH 3/4] Fix bootstrap error exit code
---
core/bootstrap/stage1.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 0e038d0a10..74b4d03cbb 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
+ 1 exit
] recover
] [
"Cannot find " write write "." print
From 7d3c590cfe1a35437d8236629d46bce154f3b24a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 16 Mar 2008 02:45:45 -0500
Subject: [PATCH 4/4] Update logging for parser change
---
extra/logging/logging.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index 5846515dca..42545500a5 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -127,8 +127,7 @@ PRIVATE>
: LOG:
#! Syntax: name level
- CREATE
- dup reset-generic
+ CREATE-WORD
dup scan-word
[ >r >r 1array stack>message r> r> log-message ] 2curry
define ; parsing