FactorWord traits = define("generic","TRAITS:");
traits.parsing = new Traits(traits);
FactorWord beginMethod = define("generic","M:");
- beginMethod.parsing = new BeginMethod(beginMethod);
- FactorWord endMethod = define("generic",";M");
- endMethod.parsing = new EndMethod(beginMethod,endMethod);
+ beginMethod.parsing = new BeginMethod(beginMethod,def);
+ FactorWord beginConstructor = define("generic","C:");
+ beginConstructor.parsing = new BeginConstructor(beginConstructor,def);
} //}}}
//{{{ getVocabulary() method
public void pushExclusiveState(FactorWord start, FactorWord defining)
throws FactorParseException
{
- if(states != null && getCurrentState().start != toplevel)
+ if(getCurrentState().start != toplevel)
scanner.error(start + " cannot be nested");
pushState(start,defining);
} //}}}
ParseState state = getCurrentState();
if(state.start != start)
scanner.error(end + " does not close " + state.start);
- states = states.next();
+ if(states.next() != null)
+ states = states.next();
return state;
} //}}}
{
String line = getLine();
int col = getColumnNumber();
- if(getReadTable().getCharacterType(line.charAt(col - 1))
+ if(line != null &&
+ getReadTable().getCharacterType(line.charAt(col - 1))
== ReadTable.WHITESPACE)
{
col--;
--- /dev/null
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $Id$
+ *
+ * Copyright (C) 2004 Slava Pestov.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+package factor.parser;
+
+import factor.*;
+
+public class BeginConstructor extends FactorParsingDefinition
+{
+ private FactorWord colon;
+
+ public BeginConstructor(FactorWord word, FactorWord colon)
+ {
+ super(word);
+ this.colon = colon;
+ }
+
+ public void eval(FactorReader reader)
+ throws Exception
+ {
+ FactorWord type = reader.nextWord(false);
+ if(type == null)
+ return;
+
+ reader.pushExclusiveState(colon,type);
+ }
+}
public class BeginMethod extends FactorParsingDefinition
{
- public BeginMethod(FactorWord word)
+ private FactorWord colon;
+
+ public BeginMethod(FactorWord word, FactorWord colon)
{
super(word);
+ this.colon = colon;
}
public void eval(FactorReader reader)
throws Exception
{
- FactorWord type = reader.nextWord(true);
+ FactorWord type = reader.nextWord(false);
if(type == null)
return;
if(generic == null)
return;
- reader.pushExclusiveState(word,generic);
+ reader.pushExclusiveState(colon,generic);
}
}
+++ /dev/null
-/* :folding=explicit:collapseFolds=1: */
-
-/*
- * $Id$
- *
- * Copyright (C) 2004 Slava Pestov.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
- * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
-
-package factor.parser;
-
-import factor.*;
-
-public class EndMethod extends FactorParsingDefinition
-{
- public FactorWord start;
-
- public EndMethod(FactorWord start, FactorWord end)
- {
- super(end);
- this.start = start;
- }
-
- public void eval(FactorReader reader)
- throws Exception
- {
- FactorReader.ParseState state = reader.popState(start,word);
- FactorWord w = state.defining;
- /* Only ever null with restartable scanner;
- error already logged, so give up */
- if(w == null)
- return;
-
- w.def = new FactorMethodDefinition(null,w,state.first);
- reader.append(w.def);
- }
-}
public class In extends FactorParsingDefinition
{
- //{{{ In constructor
- /**
- * A new definition.
- */
public In(FactorWord word)
{
super(word);
- } //}}}
+ }
- //{{{ eval() method
public void eval(FactorReader reader)
throws Exception
{
reader.setIn(next);
reader.addUse(next);
- } //}}}
+ }
}
{
FactorWord w = reader.nextWord(true);
w.def = new FactorTraitsDefinition(w);
+ reader.intern("<" + w.name + ">",true);
+ reader.intern(w.name + "?",true);
reader.append(w.def);
}
}
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: generic
-
USE: errors
USE: hashtables
USE: kernel
! A simple single-dispatch generic word system.
+! Catch-all metaclass for providing a default method.
+SYMBOL: object
+
+: define-generic ( word vtable -- )
+ 2dup "vtable" set-word-property
+ [ generic ] cons define-compound ;
+
+: <vtable> ( default -- vtable )
+ num-types [ drop dup ] vector-project nip ;
+
+: define-object ( generic definition -- )
+ <vtable> define-generic drop ;
+
+object [ define-object ] "define-method" set-word-property
+
: predicate-word ( word -- word )
word-name "?" cat2 "in" get create ;
-: builtin-predicate ( symbol type# -- )
- [ swap type eq? ] cons >r predicate-word r> define-compound ;
+: builtin-predicate ( type# symbol -- )
+ predicate-word swap [ swap type eq? ] cons define-compound ;
+
+: add-method ( definition type vtable -- )
+ >r "builtin-type" word-property r> set-vector-nth ;
+
+: define-builtin ( type generic definition -- )
+ -rot "vtable" word-property add-method ;
+
+: builtin-class ( number type -- )
+ dup undefined? [ dup define-symbol ] when
+ 2dup builtin-predicate
+ dup [ define-builtin ] "define-method" set-word-property
+ swap "builtin-type" set-word-property ;
: BUILTIN:
#! Followed by type name and type number. Define a built-in
#! type predicate with this number.
- CREATE dup undefined? [ dup define-symbol ] when scan-word
- 2dup builtin-predicate
- "builtin-type" set-word-property ; parsing
+ CREATE scan-word swap builtin-class ; parsing
: builtin-type ( symbol -- n )
"builtin-type" word-property ;
traits-map [ swap object-map eq? ] cons
define-compound ;
+: define-traits ( type generic definition -- )
+ swap rot traits-map set-hash ;
+
: TRAITS:
#! TRAITS: foo creates a new traits type. Instances can be
#! created with <foo>, and tested with foo?.
CREATE
dup define-symbol
dup init-traits-map
+ dup [ define-traits ] "define-method" set-word-property
traits-predicate ; parsing
-: add-method ( quot class vtable -- )
- >r "builtin-type" word-property r>
- set-vector-nth ;
-
-: <vtable> ( word -- vtable )
- num-types [ drop [ undefined-method ] ] vector-project
- [ "vtable" set-word-property ] keep ;
-
: add-traits-dispatch ( word vtable -- )
>r unit [ car swap traits-method call ] cons \ vector r>
add-method ;
#! GENERIC: bar creates a generic word bar that calls the
#! bar method on the traits object, with the traits object
#! on the stack.
- CREATE dup <vtable> 2dup add-traits-dispatch
- [ generic ] cons define-compound ; parsing
+ CREATE [ undefined-method ] <vtable>
+ 2dup add-traits-dispatch
+ define-generic ; parsing
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
-: define-constructor ( word -- )
- [ constructor-word [ <namespace> ] ] keep
- traits-map [ traits pick set-hash ] cons append
- define-compound ;
-
-: (;C) ( constructor traits definition -- )
+: define-constructor ( constructor traits definition -- )
>r
traits-map [ traits pick set-hash ] cons \ <namespace> swons
r> append define-compound ;
: C: ( -- constructor traits [ ] )
#! C: foo ... begins definition for <foo> where foo is a
#! traits type.
- scan-word [ constructor-word ] keep [ (;C) ] [ ] ; parsing
+ scan-word [ constructor-word ] keep
+ [ define-constructor ] [ ] ; parsing
-: (;M) ( type generic definition -- )
- pick builtin-type [
- rot "builtin-type" word-property
- rot "vtable" word-property
- set-vector-nth
- ] [
- rot traits-map [ put ] bind
- ] ifte ;
+: define-method ( type -- quotation )
+ #! In a vain attempt at something resembling a "meta object
+ #! protocol", we call the "define-method" word property with
+ #! stack ( type generic definition -- ).
+ "define-method" word-property
+ [ [ undefined-method ] ] unless* ;
: M: ( -- type generic [ ] )
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
- scan-word scan-word [ (;M) ] [ ] ;
- parsing
+ scan-word dup define-method scan-word swap [ ] ; parsing
USE: generic
USE: test
USE: kernel
+USE: math
+USE: words
+USE: lists
TRAITS: test-traits
C: test-traits ;
C: del2 ( delegate -- del2 ) [ delegate set ] extend ;
[ 5 ] [ <del1> <del2> super ] unit-test
+
+GENERIC: class-of
+
+M: fixnum class-of drop "fixnum" ;
+M: word class-of drop "word" ;
+M: cons class-of drop "cons" ;
+
+[ "fixnum" ] [ 5 class-of ] unit-test
+[ "cons" ] [ [ 1 2 3 ] class-of ] unit-test
+[ "word" ] [ \ class-of class-of ] unit-test
+[ 3.4 class-of ] unit-test-fails
+
+GENERIC: foobar
+M: object foobar drop "Hello world" ;
+M: fixnum foobar drop "Goodbye cruel world" ;
+
+[ "Hello world" ] [ 4 foobar foobar ] unit-test
+[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
projects / factor.git / commitdiff