working on inference; symbols are written to images; generic words in core

library/bootstrap/boot-stage2.factor

@@ -35,6 +35,7 @@ USE: stdio
 
 "Cold boot in progress..." print
 [
+    "/version.factor"
     "/library/kernel.factor"
     "/library/stack.factor"
     "/library/types.factor"
@@ -51,6 +52,7 @@ USE: stdio
     "/library/strings.factor"
     "/library/hashtables.factor"
     "/library/namespaces.factor"
+    "/library/generic.factor"
     "/library/math/namespace-math.factor"
     "/library/list-namespaces.factor"
     "/library/sbuf.factor"
@@ -102,6 +104,10 @@ USE: stdio
     "/library/tools/heap-stats.factor"
     "/library/gensym.factor"
     "/library/tools/interpreter.factor"
+
+    ! Inference needs to know primitive stack effects at load time
+    "/library/primitives.factor"
+
     "/library/inference/dataflow.factor"
     "/library/inference/inference.factor"
     "/library/inference/words.factor"
@@ -126,8 +132,6 @@ USE: stdio
 
     "/library/tools/jedit.factor"
 
-    "/library/primitives.factor"
-
     "/library/cli.factor"
 ] [
     dup print

library/bootstrap/boot.factor

@@ -36,6 +36,7 @@ USE: vectors
 
 primitives,
 [
+    "/version.factor"
     "/library/kernel.factor"
     "/library/stack.factor"
     "/library/types.factor"
@@ -52,6 +53,7 @@ primitives,
     "/library/strings.factor"
     "/library/hashtables.factor"
     "/library/namespaces.factor"
+    "/library/generic.factor"
     "/library/math/namespace-math.factor"
     "/library/list-namespaces.factor"
     "/library/sbuf.factor"
@@ -75,14 +77,11 @@ primitives,
     cross-compile-resource
 ] each
 
-version,
-
 IN: init
 DEFER: boot
 
 [
     boot
     "Good morning!" print
-    global vector? [ "vocabs set" ] [ "vocabs not set" ] ifte print
     "/library/bootstrap/boot-stage2.factor" run-resource
 ] boot-quot set

library/bootstrap/cross-compiler.factor

@@ -383,12 +383,9 @@ IN: image
         heap-stats
         throw
     ] [
-        swap succ tuck primitive,
+        swap succ tuck f define,
     ] each drop ;
 
-: version, ( -- )
-    "version" [ "kernel" ] search version unit compound, ;
-
 : make-image ( name -- )
     #! Make an image for the C interpreter.
     [
@@ -407,7 +404,7 @@ IN: image
 
 : cross-compile-resource ( resource -- )
     [
-        ! Change behavior of ;
+        ! Change behavior of ; and SYMBOL:
-        [ compound, ] ";-hook" set
+        [ pick USE: prettyprint . define, ] "define-hook" set
         run-resource
     ] with-scope ;

library/bootstrap/image.factor

@@ -145,11 +145,11 @@ SYMBOL: boot-quot
 
 ( Fixnums )
 
-: 'fixnum ( n -- tagged ) fixnum-tag immediate ;
+: emit-fixnum ( n -- tagged ) fixnum-tag immediate ;
 
 ( Bignums )
 
-: 'bignum ( bignum -- tagged )
+: emit-bignum ( bignum -- tagged )
     object-tag here-as >r
     bignum-type >header emit
     dup 0 = 1 2 ? emit ( capacity )
@@ -166,11 +166,11 @@ SYMBOL: boot-quot
 : t,
     object-tag here-as "t" set
     t-type >header emit
-    0 'fixnum emit ;
+    0 emit-fixnum emit ;
 
-:  0,  0 'bignum drop ;
+:  0,  0 emit-bignum drop ;
-:  1,  1 'bignum drop ;
+:  1,  1 emit-bignum drop ;
-: -1, -1 'bignum drop ;
+: -1, -1 emit-bignum drop ;
 
 ( Beginning of the image )
 ! The image proper begins with the header, then T,
@@ -199,36 +199,37 @@ SYMBOL: boot-quot
         dup word? [ fixup-word ] when
     ] vector-map image set ;
 
-: 'word ( word -- pointer )
+: emit-word ( word -- pointer )
     dup pooled-object dup [ nip ] [ drop ] ifte ;
 
 ( Conses )
 
 DEFER: '
 
-: cons, ( -- pointer ) cons-tag here-as ;
+: emit-cons ( c -- tagged )
-: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
+    uncons ' swap '
+    cons-tag here-as
+    -rot emit emit ;
 
 ( Strings )
 
 : align-string ( n str -- )
     tuck str-length - CHAR: \0 fill cat2 ;
 
-: emit-string ( str -- )
+: emit-chars ( str -- )
     "big-endian" get [ str-reverse ] unless
     0 swap [ swap 16 shift + ] str-each emit ;
 
 : (pack-string) ( n list -- )
     #! Emit bytes for a string, with n characters per word.
     [
-        2dup str-length > [ dupd align-string ] when
+        2dup str-length > [ dupd align-string ] when  emit-chars
-        emit-string
     ] each drop ;
 
 : pack-string ( string -- )
     char tuck swap split-n (pack-string) ;
 
-: string, ( string -- )
+: (emit-string) ( string -- )
     object-tag here-as swap
     string-type >header emit
     dup str-length emit
@@ -236,13 +237,13 @@ DEFER: '
     pack-string
     pad ;
 
-: 'string ( string -- pointer )
+: emit-string ( string -- pointer )
     #! We pool strings so that each string is only written once
     #! to the image
     dup pooled-object dup [
         nip
     ] [
-        drop dup string, dup >r pool-object r>
+        drop dup (emit-string) dup >r pool-object r>
     ] ifte ;
 
 ( Word definitions )
@@ -261,15 +262,16 @@ DEFER: '
     dup word-name over word-vocabulary 
     (vocabulary) set-hash ;
 
-: 'plist ( word -- plist )
+: emit-plist ( word -- plist )
     [
         dup word-name "name" swons ,
         dup word-vocabulary "vocabulary" swons ,
         "parsing" word-property [ t "parsing" swons , ] when
     ] make-list ' ;
 
-: (worddef,) ( word primitive parameter -- )
+: define, ( word primitive parameter -- )
-    ' >r >r dup (word+) dup 'plist >r
+    #! Write a word definition to the image.
+    ' >r >r dup (word+) dup emit-plist >r
     word, pool-object
     r> ( -- plist )
     r> ( primitive -- ) emit
@@ -278,12 +280,9 @@ DEFER: '
     0 emit ( padding )
     0 emit ;
 
-: primitive, ( word primitive -- ) f (worddef,) ;
-: compound, ( word definition -- ) 1 swap (worddef,) ;
-
 ( Arrays and vectors )
 
-: 'array ( list -- pointer )
+: emit-array ( list -- pointer )
     [ ' ] map
     object-tag here-as >r
     array-type >header emit
@@ -291,8 +290,8 @@ DEFER: '
     ( elements -- ) [ emit ] each
     pad r> ;
 
-: 'vector ( vector -- pointer )
+: emit-vector ( vector -- pointer )
-    dup vector>list 'array swap vector-length
+    dup vector>list emit-array swap vector-length
     object-tag here-as >r
     vector-type >header emit
     emit ( length )
@@ -303,12 +302,12 @@ DEFER: '
 
 : ' ( obj -- pointer )
     [
-        [ fixnum?  ] [ 'fixnum      ]
+        [ fixnum?  ] [ emit-fixnum      ]
-        [ bignum?  ] [ 'bignum      ]
+        [ bignum?  ] [ emit-bignum      ]
-        [ word?    ] [ 'word        ]
+        [ word?    ] [ emit-word        ]
-        [ cons?    ] [ 'cons        ]
+        [ cons?    ] [ emit-cons        ]
-        [ string?  ] [ 'string      ]
+        [ string?  ] [ emit-string      ]
-        [ vector?  ] [ 'vector      ]
+        [ vector?  ] [ emit-vector      ]
         [ t =      ] [ drop "t" get     ]
         ! f is #define F RETAG(0,OBJECT_TYPE)
         [ f =      ] [ drop object-tag  ]

library/bootstrap/init-stage2.factor

@@ -83,9 +83,9 @@ init-error-handler
 
 0 [ drop succ ] each-word unparse write " words" print 
 
-"Inferring stack effects..." print
+! "Inferring stack effects..." print
-0 [ unit try-infer [ succ ] when ] each-word
+! 0 [ unit try-infer [ succ ] when ] each-word
-unparse write " words have a stack effect" print
+! unparse write " words have a stack effect" print
 
 "Bootstrapping is complete." print
 "Now, you can run ./f factor.image" print

library/generic.factor

@@ -0,0 +1,133 @@
+! :folding=indent: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.
+
+IN: generic
+
+USE: combinators
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: stack
+USE: strings
+USE: words
+USE: vectors
+
+! A simple prototype-based generic word system.
+
+! Hashtable slot holding a selector->method map.
+SYMBOL: traits
+
+! Hashtable slot holding an optional delegate. Any undefined
+! methods are called on the delegate. The object can also
+! manually pass any methods on to the delegate.
+SYMBOL: delegate
+
+: traits-map ( type -- hash )
+    #! The method map word property maps selector words to
+    #! definitions.
+    "traits-map" word-property ;
+
+: object-map ( obj -- hash )
+    #! Get the method map for an object.
+    #! We will use hashtable? here when its a first-class type.
+    dup vector? [ traits swap hash ] [ drop f ] ifte ;
+
+: init-traits-map ( word -- )
+    <namespace> "traits-map" set-word-property ;
+
+: no-method
+    "No applicable method." throw ;
+
+: method ( selector traits -- quot )
+    #! Look up the method with the traits object on the stack.
+    2dup object-map hash* dup [
+        nip nip cdr ( method is defined )
+    ] [
+        drop delegate swap hash* dup [
+            cdr method ( check delegate )
+        ] [
+            3drop [ no-method ] ( no delegate )
+        ] ifte
+    ] ifte ;
+
+: predicate-word ( word -- word )
+    word-name "?" cat2 "in" get create ;
+
+: define-predicate ( word -- )
+    #! foo? where foo is a traits type tests if the top of stack
+    #! is of this type.
+    dup predicate-word swap
+    [ object-map ] swap traits-map [ eq? ] cons append
+    define-compound ;
+
+: 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
+    define-predicate ; parsing
+
+: GENERIC:
+    #! 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 unit [ car over method call ] cons
+    define-compound ; 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: ( -- word [ ] )
+    #! C: foo ... begins definition for <foo> where foo is a
+    #! traits type. We have to reverse the list at the end,
+    #! since the parser conses onto the list, and it will be
+    #! reversed again by ;C.
+    scan-word [ constructor-word [ <namespace> ] ] keep
+    traits-map [ traits pick set-hash ] cons append reverse ;
+    parsing
+
+: ;C ( word [ ] -- )
+    POSTPONE: ; ; parsing
+
+: M: ( -- type generic [ ] )
+    #! M: foo bar begins a definition of the bar generic word
+    #! specialized to the foo type.
+    scan-word scan-word f ; parsing
+
+: ;M ( type generic def -- )
+    #! ;M ends a method definition.
+    rot traits-map [ reverse put ] bind ; parsing

library/inference/branches.factor

@@ -27,6 +27,7 @@
 
 IN: inference
 USE: combinators
+USE: dataflow
 USE: errors
 USE: interpreter
 USE: kernel
@@ -40,8 +41,6 @@ USE: vectors
 USE: words
 USE: hashtables
 
-DEFER: (infer)
-
 : infer-branch ( quot -- [ in-d | datastack ] dataflow )
     #! Infer the quotation's effect, restoring the meta
     #! interpreter state afterwards.
@@ -98,23 +97,23 @@ DEFER: (infer)
         [ drop f ] when
     ] catch ;
 
-: infer-branches ( branchlist consume instruction -- )
+: infer-branches ( branchlist instruction -- )
     #! Recursive stack effect inference is done here. If one of
     #! the branches has an undecidable stack effect, we set the
     #! base case to this stack effect and try again.
-    rot f over [ recursive-branch or ] each [
+    swap f over [ recursive-branch or ] each [
         [ [ car infer-branch , ] map ] make-list swap
-        >r dataflow, r> unify
+        >r dataflow, drop r> unify
     ] [
-        "Foo!" throw
+        current-word no-base-case
     ] ifte ;
 
 : infer-ifte ( -- )
     #! Infer effects for both branches, unify.
     3 ensure-d
-    \ drop dataflow-word, pop-d
+    \ drop CALL dataflow, drop pop-d
-    \ drop dataflow-word, pop-d 2list
+    \ drop CALL dataflow, drop pop-d 2list
-    1 inputs IFTE
+    IFTE
     pop-d drop ( condition )
     infer-branches ;
 
@@ -129,16 +128,16 @@ DEFER: (infer)
 : infer-generic ( -- )
     #! Infer effects for all branches, unify.
     2 ensure-d
-    \ drop dataflow-word, pop-d vtable>list
+    \ drop CALL dataflow, drop pop-d vtable>list
-    1 inputs GENERIC
+    GENERIC
     peek-d drop ( dispatch )
     infer-branches ;
 
 : infer-2generic ( -- )
     #! Infer effects for all branches, unify.
     3 ensure-d
-    \ drop dataflow-word, pop-d vtable>list
+    \ drop CALL dataflow, drop pop-d vtable>list
-    2 inputs 2GENERIC
+    2GENERIC
     peek-d drop ( dispatch )
     peek-d drop ( dispatch )
     infer-branches ;

library/inference/dataflow.factor

@@ -25,7 +25,8 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: inference
+IN: dataflow
+USE: inference
 USE: interpreter
 USE: lists
 USE: math
@@ -46,24 +47,45 @@ SYMBOL: IFTE
 SYMBOL: GENERIC
 SYMBOL: 2GENERIC
 
+SYMBOL: node-consume-d
+SYMBOL: node-produce-d
+SYMBOL: node-consume-r
+SYMBOL: node-produce-r
+SYMBOL: node-op
+
+! PUSH nodes have this field set to the value being pushed.
+! CALL nodes have this as the word being called
+SYMBOL: node-param
+
+: <dataflow-node> ( param op -- node )
+    <namespace> [
+        node-op set
+        node-param set
+        { } node-consume-d set
+        { } node-produce-d set
+        { } node-consume-r set
+        { } node-produce-r set
+    ] extend ;
+
+: node-inputs ( d-count r-count -- )
+    #! Execute in the node's namespace.
+    meta-r get vector-tail* node-consume-r set
+    meta-d get vector-tail* node-consume-d set ;
+
+: dataflow-inputs ( [ in | out ] node -- )
+    [ car 0 node-inputs ] bind ;
+
+: node-outputs ( d-count r-count -- )
+    #! Execute in the node's namespace.
+    meta-r get vector-tail* node-produce-r set
+    meta-d get vector-tail* node-produce-d set ;
+
+: dataflow-outputs ( [ in | out ] node -- )
+    [ cdr 0 node-outputs ] bind ;
+
 : get-dataflow ( -- IR )
     dataflow-graph get reverse ;
 
-: inputs ( count -- vector )
+: dataflow, ( param op -- node )
-    meta-d get [ vector-length swap - ] keep vector-tail ;
+    #! Add a node to the dataflow IR.
-
+    <dataflow-node> dup dataflow-graph cons@ ;
-: dataflow, ( consume instruction parameters -- )
-    #! Add a node to the dataflow IR. Each node is a list of
-    #! three elements:
-    #! - vector of elements consumed from stack
-    #! - a symbol CALL, JUMP or PUSH
-    #! - parameter(s) to insn
-    unit cons cons  dataflow-graph cons@ ;
-
-: dataflow-literal, ( lit -- )
-    >r 0 inputs PUSH r> dataflow, ;
-
-: dataflow-word, ( word -- )
-    [
-        "infer-effect" word-property car inputs CALL
-    ] keep dataflow, ;

library/inference/inference.factor

@@ -27,6 +27,7 @@
 
 IN: inference
 USE: combinators
+USE: dataflow
 USE: errors
 USE: interpreter
 USE: kernel
@@ -83,9 +84,6 @@ SYMBOL: entry-effect
     #! Push count of unknown results.
     [ gensym push-d ] times ;
 
-: consume/produce ( [ in | out ] -- )
-    unswons dup ensure-d consume-d produce-d ;
-
 : effect ( -- [ in | out ] )
     #! After inference is finished, collect information.
     d-in get  meta-d get vector-length cons ;
@@ -111,7 +109,7 @@ DEFER: apply-word
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    dup dataflow-literal,  recursive-state get cons push-d ;
+    dup PUSH dataflow, drop  recursive-state get cons push-d ;
 
 : apply-object ( obj -- )
     #! Apply the object's stack effect to the inferencer state.

library/inference/stack.factor

@@ -26,6 +26,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: inference
+USE: dataflow
 USE: interpreter
 USE: stack
 USE: words
@@ -33,31 +34,25 @@ USE: lists
 
 : meta-infer ( word -- )
     #! Mark a word as being partially evaluated.
-    dup unit [
+    dup [
-        car dup dataflow-word, host-word
+       dup unit , \ car , \ dup ,
-    ] cons  "infer" set-word-property ;
+       "infer-effect" word-property ,
+       [ drop host-word ] ,
+       \ with-dataflow ,
+    ] make-list "infer" set-word-property ;
 
 \ >r [
-    \ >r dataflow-word, pop-d push-r
+    \ >r CALL dataflow, drop pop-d push-r
 ] "infer" set-word-property
 \ r> [
-    \ r> dataflow-word, pop-r push-d
+    \ r> CALL dataflow, drop pop-r push-d
 ] "infer" set-word-property
 
 \ drop meta-infer
-\ 2drop meta-infer 
-\ 3drop meta-infer
 \ dup meta-infer
-\ 2dup meta-infer
-\ 3dup meta-infer
 \ swap meta-infer
 \ over meta-infer
 \ pick meta-infer
 \ nip meta-infer
 \ tuck meta-infer
 \ rot meta-infer
-\ -rot meta-infer
-\ 2nip meta-infer
-\ transp meta-infer
-\ dupd meta-infer
-\ swapd meta-infer

library/inference/words.factor

@@ -27,6 +27,7 @@
 
 IN: inference
 USE: combinators
+USE: dataflow
 USE: errors
 USE: interpreter
 USE: kernel
@@ -39,41 +40,67 @@ USE: strings
 USE: vectors
 USE: words
 USE: hashtables
+USE: prettyprint
+
+: with-dataflow ( word [ in | out ] quot -- )
+    #! Take input parameters, execute quotation, take output
+    #! parameters, add node. The quotation is called with the
+    #! stack effect.
+    over car ensure-d
+    rot CALL dataflow,
+    [ pick swap dataflow-inputs ] keep
+    pick 2slip swap dataflow-outputs ; inline
+
+: consume/produce ( word [ in | out ] -- )
+    #! Add a node to the dataflow graph that consumes and
+    #! produces a number of values.
+    [ unswons consume-d produce-d ] with-dataflow ;
 
 : apply-effect ( word [ in | out ] -- )
     #! If a word does not have special inference behavior, we
     #! either execute the word in the meta interpreter (if it is
     #! side-effect-free and all parameters are literal), or
     #! simply apply its stack effect to the meta-interpreter.
-    dup car ensure-d 
     over "infer" word-property dup [
-        nip nip call
+        swap car ensure-d call drop
     ] [
-        drop swap dataflow-word, consume/produce
+        drop consume/produce
     ] ifte ;
 
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 throw ;
 
-: infer-compound ( word -- effect )
+: inline-compound ( word -- effect )
-    #! Infer a word's stack effect, and cache it.
+    #! Infer the stack effect of a compound word in the current
+    #! inferencer instance.
+    [ word-parameter (infer) effect ] with-recursive-state ;
+
+: (infer-compound) ( word -- effect )
+    #! Infer a word's stack effect in a separate inferencer
+    #! instance.
     [
         recursive-state get init-inference
-        [
+        dup inline-compound
-            dup word-parameter (infer) effect
         [ "infer-effect" set-word-property ] keep
-        ] with-recursive-state
     ] with-scope ;
 
-: inline-compound ( word -- )
+: infer-compound ( word -- )
-    [ word-parameter (infer) ] with-recursive-state ;
+    #! Infer the stack effect of a compound word in a separate
+    #! inferencer instance, caching the result.
+    [
+        dup (infer-compound) consume/produce
+    ] [
+        [
+            swap t "no-effect" set-word-property rethrow
+        ] when*
+    ] catch ;
 
 : apply-compound ( word -- )
     #! Infer a compound word's stack effect.
     dup "inline" word-property [
-        inline-compound
+        inline-compound drop
     ] [
-        dup infer-compound consume/produce dataflow-word,
+        infer-compound
     ] ifte ;
 
 : current-word ( -- word )
@@ -95,11 +122,14 @@ USE: hashtables
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error.
     base-case swap hash dup [
-        nip consume/produce
+        consume/produce
     ] [
         drop no-base-case
     ] ifte ;
 
+: no-effect? ( word -- ? )
+    "no-effect" word-property ;
+
 : apply-word ( word -- )
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get assoc dup [
@@ -110,6 +140,7 @@ USE: hashtables
         ] [
             drop
             [
+                [ no-effect? ] [ no-effect      ]
                 [ compound?  ] [ apply-compound ]
                 [ symbol?    ] [ apply-literal  ]
                 [ drop t     ] [ no-effect      ]
@@ -118,7 +149,7 @@ USE: hashtables
     ] ifte ;
 
 : infer-call ( [ rstate | quot ] -- )
-    \ drop dataflow-word,
+    \ drop CALL dataflow, drop
     [
         dataflow-graph off
         pop-d uncons recursive-state set (infer)
@@ -132,3 +163,4 @@ USE: hashtables
 \ - [ 2 | 1 ] "infer-effect" set-word-property
 \ * [ 2 | 1 ] "infer-effect" set-word-property
 \ / [ 2 | 1 ] "infer-effect" set-word-property
+\ hashcode [ 1 | 1 ] "infer-effect" set-word-property

library/stack.factor

@@ -29,15 +29,15 @@ IN: stack
 USE: vectors
 
 : nop ( -- ) ;
-: 2drop ( x x -- ) drop drop ;
+: 2drop ( x x -- ) drop drop ; inline
-: 3drop ( x x x -- ) drop drop drop ;
+: 3drop ( x x x -- ) drop drop drop ; inline
-: 2dup ( x y -- x y x y ) over over ;
+: 2dup ( x y -- x y x y ) over over ; inline
-: 3dup ( x y z -- x y z x y z ) pick pick pick ;
+: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
-: -rot ( x y z -- z x y ) rot rot ;
+: -rot ( x y z -- z x y ) rot rot ; inline
-: dupd ( x y -- x x y ) >r dup r> ;
+: dupd ( x y -- x x y ) >r dup r> ; inline
-: swapd ( x y z -- y x z ) >r swap r> ;
+: swapd ( x y z -- y x z ) >r swap r> ; inline
-: transp ( x y z -- z y x ) swap rot ;
+: transp ( x y z -- z y x ) swap rot ; inline
-: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ;
+: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ; inline
 
 : clear ( -- )
     #! Clear the datastack. For interactive use only; invoking

library/syntax/parse-syntax.factor

@@ -149,15 +149,14 @@ IN: syntax
     #! Begin a word definition. Word name follows.
     CREATE [ ] "in-definition" on ; parsing
 
-: ;-hook ( word def -- )
-    ";-hook" get [ call ] [ define-compound ] ifte* ;
-
 : ;
     #! End a word definition.
-    "in-definition" off reverse ;-hook ; parsing
+    "in-definition" off reverse define-compound ; parsing
 
 ! Symbols
-: SYMBOL: CREATE define-symbol ; parsing
+: SYMBOL:
+    #! A symbol is a word that pushes itself when executed.
+    CREATE define-symbol ; parsing
 
 : \
     #! Parsed as a piece of code that pushes a word on the stack
@@ -165,11 +164,18 @@ IN: syntax
     scan-word unit parsed  \ car parsed ; parsing
 
 ! Vocabularies
-: DEFER: CREATE drop ; parsing
+: DEFER:
+    #! Create a word with no definition. Used for mutually
+    #! recursive words.
+    CREATE drop ; parsing
 : FORGET: scan-word forget ; parsing
 
-: USE: scan "use" cons@ ; parsing
+: USE:
-: IN: scan dup "use" cons@ "in" set ; parsing
+    #! Add vocabulary to search path.
+    scan "use" cons@ ; parsing
+: IN:
+    #! Set vocabulary for new definitions.
+    scan dup "use" cons@ "in" set ; parsing
 
 ! Char literal
 : CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
@@ -188,9 +194,8 @@ IN: syntax
     [ parse-string "col" get ] make-string
     swap "col" set parsed ; parsing
 
-! Complex literal
 : #{
-    #! Read #{ real imaginary #}
+    #! Complex literal - #{ real imaginary #}
     scan str>number scan str>number rect> "}" expect parsed ;
     parsing
 

library/syntax/prettyprint.factor

@@ -150,7 +150,10 @@ DEFER: prettyprint*
 
 : prettyprint-{} ( indent vector -- indent )
     dup vector-length 0 = [
-        drop prettyprint-{ prettyprint-}
+        drop
+        \ { prettyprint-word
+        prettyprint-space
+        \ } prettyprint-word
     ] [
         swap prettyprint-{ swap prettyprint-vector prettyprint-}
     ] ifte ;
@@ -163,7 +166,10 @@ DEFER: prettyprint*
 
 : prettyprint-{{}} ( indent hashtable -- indent )
     hash>alist dup length 0 = [
-        drop prettyprint-{{ prettyprint-}}
+        drop
+        \ {{ prettyprint-word
+        prettyprint-space 
+        \ }} prettyprint-word
     ] [
         swap prettyprint-{{ swap prettyprint-list prettyprint-}}
     ] ifte ;

library/syntax/see.factor

@@ -101,7 +101,7 @@ USE: words
     "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
 
 : see-symbol ( word -- )
-    \ SYMBOL: prettyprint-word . ;
+    \ SYMBOL: prettyprint-word prettyprint-space . ;
 
 : see-undefined ( word -- )
     drop "Not defined" print ;

library/test/dataflow.factor

@@ -6,10 +6,10 @@ USE: test
 USE: logic
 USE: combinators
 
-[ t ] [ \ + [ 2 2 + ] dataflow tree-contains? >boolean ] unit-test
+! [ t ] [ \ + [ 2 2 + ] dataflow tree-contains? >boolean ] unit-test
-[ t ] [ 3 [ [ sq ] [ 3 + ] ifte ] dataflow tree-contains? >boolean ] unit-test
+! [ t ] [ 3 [ [ sq ] [ 3 + ] ifte ] dataflow tree-contains? >boolean ] unit-test
-
+! 
-: inline-test
+! : inline-test
-    car car ; inline
+!     car car ; inline
-
+! 
-[ t ] [ \ car [ inline-test ] dataflow tree-contains? >boolean ] unit-test
+! [ t ] [ \ car [ inline-test ] dataflow tree-contains? >boolean ] unit-test

library/test/generic.factor

@@ -0,0 +1,58 @@
+IN: scratchpad
+USE: hashtables
+USE: namespaces
+USE: generic
+USE: stack
+USE: test
+
+TRAITS: test-traits
+C: test-traits ;C
+
+[ t ] [ <test-traits> test-traits? ] unit-test
+[ f ] [ "hello" test-traits? ] unit-test
+[ f ] [ <namespace> test-traits? ] unit-test
+
+GENERIC: foo
+
+M: test-traits foo drop 12 ;M
+
+TRAITS: another-test
+C: another-test ;C
+
+M: another-test foo drop 13 ;M
+
+[ 12 ] [ <test-traits> foo ] unit-test
+[ 13 ] [ <another-test> foo ] unit-test
+
+TRAITS: quux
+C: quux ;C
+
+M: quux foo "foo" swap hash ;M
+
+[
+    "Hi"
+] [
+    <quux> [
+        "Hi" "foo" set
+    ] extend foo
+] unit-test
+
+TRAITS: ctr-test
+C: ctr-test [ 5 "x" set ] extend ;C
+
+[
+    5
+] [
+    <ctr-test> [ "x" get ] bind
+] unit-test
+
+TRAITS: del1
+C: del1 ;C
+
+GENERIC: super
+M: del1 super drop 5 ;M
+
+TRAITS: del2
+C: del2 ( delegate -- del2 ) [ delegate set ] extend ;C
+
+[ 5 ] [ <del1> <del2> super ] unit-test

library/test/test.factor

@@ -78,6 +78,7 @@ USE: unparser
         "hashtables"
         "strings"
         "namespaces"
+        "generic"
         "files"
         "format"
         "parser"
@@ -111,6 +112,7 @@ USE: unparser
         "threads"
         "parsing-word"
         "inference"
+        "dataflow"
         "interpreter"
     ] [
         test

library/test/vectors.factor

@@ -7,6 +7,10 @@ USE: test
 USE: vectors
 USE: strings
 
+[ 3 { } vector-nth ] unit-test-fails
+[ 3 #{ 1 2 } vector-nth ] unit-test-fails
+
+[ 5 list>vector ] unit-test-fails
 [ { } ] [ [ ] list>vector ] unit-test
 [ { 1 2 } ] [ [ 1 2 ] list>vector ] unit-test
 
@@ -53,3 +57,5 @@ unit-test
 [ { } ] [ 2 { 1 2 } vector-tail ] unit-test
 [ { 3 4 } ] [ 2 { 1 2 3 4 } vector-tail ] unit-test
 [ 2 { } vector-tail ] unit-test-fails
+
+[ { 3 } ] [ 1 { 1 2 3 } vector-tail* ] unit-test

library/vectors.factor

@@ -120,3 +120,9 @@ DEFER: vector-map
     2dup vector-length swap - [
         pick + over vector-nth
     ] vector-project nip nip ;
+
+: vector-tail* ( n vector -- vector )
+    #! Unlike vector-tail, n is an index from the end of the
+    #! vector. For example, if n=1, this returns a vector of
+    #! one element.
+    [ vector-length swap - ] keep vector-tail ;

library/words.factor

@@ -55,25 +55,23 @@ USE: strings
 : word ( -- word ) global [ "last-word" get ] bind ;
 : set-word ( word -- ) global [ "last-word" set ] bind ;
 
-: define-compound ( word def -- )
+: (define) ( word primitive parameter -- )
-    over set-word-parameter
+    #! Define a word in the current Factor instance.
-    1 over set-word-primitive
+    pick set-word-parameter
+    over set-word-primitive
     f "parsing" set-word-property ;
 
-: define-symbol ( word -- )
+: define ( word primitive parameter -- )
-    dup dup set-word-parameter
+    #! The define-hook is set by the image bootstrapping code.
-    2 swap set-word-primitive ;
+    "define-hook" get [ call ] [ (define) ] ifte* ;
 
-: word-name ( word -- name )
+: define-compound ( word def -- ) 1 swap define ;
-    "name" word-property ;
+: define-symbol   ( word -- ) 2 over define ;
 
-: word-vocabulary ( word -- vocab )
+: word-name       ( word -- str ) "name" word-property ;
-    "vocabulary" word-property ;
+: word-vocabulary ( word -- str ) "vocabulary" word-property ;
-
+: stack-effect    ( word -- str ) "stack-effect" word-property ;
-: stack-effect ( word -- str )
+: documentation   ( word -- str ) "documentation" word-property ;
-    "stack-effect" word-property ;
-: documentation ( word -- str )
-    "documentation" word-property ;
 
 : vocabs ( -- list )
     #! Push a list of vocabularies.

native/factor.h

@@ -76,8 +76,8 @@ typedef unsigned char BYTE;
 
 #include "memory.h"
 #include "error.h"
-#include "gc.h"
 #include "types.h"
+#include "gc.h"
 #include "boolean.h"
 #include "word.h"
 #include "run.h"

version.factor

@@ -0,0 +1,2 @@
+IN: kernel
+: version "0.69" ;