steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

cvs
Slava Pestov 2004-11-29 00:07:24 +00:00
parent 3dccc4d2d5
commit cfb85ef884
23 changed files with 420 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
library/bootstrap/boot-stage2.factor
View File

@ -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

5
library/bootstrap/boot.factor
View File

@ -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

9
library/bootstrap/cross-compiler.factor
View File

@ -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 ;
[ compound, ] ";-hook" set
! Change behavior of ; and SYMBOL:
[ pick USE: prettyprint . define, ] "define-hook" set
run-resource
] with-scope ;

59
library/bootstrap/image.factor
View File

@ -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 ;
: 1, 1 'bignum drop ;
: -1, -1 'bignum drop ;
: 0, 0 emit-bignum drop ;
: 1, 1 emit-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 ;
: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
: emit-cons ( c -- tagged )
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
emit-string
2dup str-length > [ dupd align-string ] when emit-chars
] 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 -- )
' >r >r dup (word+) dup 'plist >r
: define, ( word primitive parameter -- )
#! 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 )
dup vector>list 'array swap vector-length
: emit-vector ( vector -- pointer )
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 ]
[ bignum? ] [ 'bignum ]
[ word? ] [ 'word ]
[ cons? ] [ 'cons ]
[ string? ] [ 'string ]
[ vector? ] [ 'vector ]
[ fixnum? ] [ emit-fixnum ]
[ bignum? ] [ emit-bignum ]
[ word? ] [ emit-word ]
[ cons? ] [ emit-cons ]
[ string? ] [ emit-string ]
[ vector? ] [ emit-vector ]
[ t = ] [ drop "t" get ]
! f is #define F RETAG(0,OBJECT_TYPE)
[ f = ] [ drop object-tag ]

6
library/bootstrap/init-stage2.factor
View File

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

133
library/generic.factor Normal file
View File

@ -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

25
library/inference/branches.factor
View File

@ -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 dataflow-word, pop-d 2list
1 inputs IFTE
\ drop CALL dataflow, drop pop-d
\ drop CALL dataflow, drop pop-d 2list
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
1 inputs GENERIC
\ drop CALL dataflow, drop pop-d vtable>list
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
2 inputs 2GENERIC
\ drop CALL dataflow, drop pop-d vtable>list
2GENERIC
peek-d drop ( dispatch )
peek-d drop ( dispatch )
infer-branches ;

60
library/inference/dataflow.factor
View File

@ -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 )
meta-d get [ vector-length swap - ] keep vector-tail ;
: 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, ;
: dataflow, ( param op -- node )
#! Add a node to the dataflow IR.
<dataflow-node> dup dataflow-graph cons@ ;

6
library/inference/inference.factor
View File

@ -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.

23
library/inference/stack.factor
View File

@ -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 [
car dup dataflow-word, host-word
] cons "infer" set-word-property ;
dup [
dup unit , \ car , \ dup ,
"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

60
library/inference/words.factor
View File

@ -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 )
#! Infer a word's stack effect, and cache it.
: inline-compound ( word -- effect )
#! 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 word-parameter (infer) effect
dup inline-compound
[ "infer-effect" set-word-property ] keep
] with-recursive-state
] with-scope ;
: inline-compound ( word -- )
[ word-parameter (infer) ] with-recursive-state ;
: infer-compound ( word -- )
#! 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

18
library/stack.factor
View File

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

25
library/syntax/parse-syntax.factor
View File

@ -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
: IN: scan dup "use" cons@ "in" set ; parsing
: USE:
#! 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

10
library/syntax/prettyprint.factor
View File

@ -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 ;

2
library/syntax/see.factor
View File

@ -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 ;

14
library/test/dataflow.factor
View File

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

58
library/test/generic.factor Normal file
View File

@ -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

2
library/test/test.factor
View File

@ -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

6
library/test/vectors.factor
View File

@ -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

6
library/vectors.factor
View File

@ -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 ;

28
library/words.factor
View File

@ -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 -- )
over set-word-parameter
1 over set-word-primitive
: (define) ( word primitive parameter -- )
#! Define a word in the current Factor instance.
pick set-word-parameter
over set-word-primitive
f "parsing" set-word-property ;
: define-symbol ( word -- )
dup dup set-word-parameter
2 swap set-word-primitive ;
: define ( word primitive parameter -- )
#! The define-hook is set by the image bootstrapping code.
"define-hook" get [ call ] [ (define) ] ifte* ;
: word-name ( word -- name )
"name" word-property ;
: define-compound ( word def -- ) 1 swap define ;
: define-symbol ( word -- ) 2 over define ;
: word-vocabulary ( word -- vocab )
"vocabulary" word-property ;
: stack-effect ( word -- str )
"stack-effect" word-property ;
: documentation ( word -- str )
"documentation" word-property ;
: word-name ( word -- str ) "name" word-property ;
: word-vocabulary ( word -- str ) "vocabulary" word-property ;
: stack-effect ( word -- str ) "stack-effect" word-property ;
: documentation ( word -- str ) "documentation" word-property ;
: vocabs ( -- list )
#! Push a list of vocabularies.

2
native/factor.h
View File

@ -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"

2
version.factor Normal file
View File

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