"Cold boot in progress..." print
[
+ "/version.factor"
"/library/kernel.factor"
"/library/stack.factor"
"/library/types.factor"
"/library/strings.factor"
"/library/hashtables.factor"
"/library/namespaces.factor"
+ "/library/generic.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/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"
"/library/tools/jedit.factor"
- "/library/primitives.factor"
-
"/library/cli.factor"
] [
dup print
primitives,
[
+ "/version.factor"
"/library/kernel.factor"
"/library/stack.factor"
"/library/types.factor"
"/library/strings.factor"
"/library/hashtables.factor"
"/library/namespaces.factor"
+ "/library/generic.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
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
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.
[
: 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 ;
( 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 )
: 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,
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
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 )
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
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
( 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 )
: ' ( obj -- pointer )
[
- [ fixnum? ] [ 'fixnum ]
- [ bignum? ] [ 'bignum ]
- [ word? ] [ 'word ]
- [ cons? ] [ 'cons ]
- [ string? ] [ 'string ]
- [ vector? ] [ 'vector ]
- [ t = ] [ drop "t" get ]
+ [ 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 ]
+ [ f = ] [ drop object-tag ]
[ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
] cond ;
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
--- /dev/null
+! :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
IN: inference
USE: combinators
+USE: dataflow
USE: errors
USE: interpreter
USE: kernel
USE: words
USE: hashtables
-DEFER: (infer)
-
: infer-branch ( quot -- [ in-d | datastack ] dataflow )
#! Infer the quotation's effect, restoring the meta
#! interpreter state afterwards.
[ 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 ;
: 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 ;
! 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
SYMBOL: GENERIC
SYMBOL: 2GENERIC
-: get-dataflow ( -- IR )
- dataflow-graph get reverse ;
+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 ;
-: inputs ( count -- vector )
- meta-d get [ vector-length swap - ] keep vector-tail ;
+: 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, ( 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-inputs ( [ in | out ] node -- )
+ [ car 0 node-inputs ] bind ;
-: dataflow-literal, ( lit -- )
- >r 0 inputs PUSH r> dataflow, ;
+: 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 ;
-: 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@ ;
IN: inference
USE: combinators
+USE: dataflow
USE: errors
USE: interpreter
USE: kernel
#! 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 ;
: 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.
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: inference
+USE: dataflow
USE: interpreter
USE: stack
USE: words
: 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
IN: inference
USE: combinators
+USE: dataflow
USE: errors
USE: interpreter
USE: kernel
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
- [ "infer-effect" set-word-property ] keep
- ] with-recursive-state
+ dup inline-compound
+ [ "infer-effect" set-word-property ] keep
] 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 )
#! 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 [
] [
drop
[
- [ compound? ] [ apply-compound ]
- [ symbol? ] [ apply-literal ]
- [ drop t ] [ no-effect ]
+ [ no-effect? ] [ no-effect ]
+ [ compound? ] [ apply-compound ]
+ [ symbol? ] [ apply-literal ]
+ [ drop t ] [ no-effect ]
] cond
] ifte
] ifte ;
: infer-call ( [ rstate | quot ] -- )
- \ drop dataflow-word,
+ \ drop CALL dataflow, drop
[
dataflow-graph off
pop-d uncons recursive-state set (infer)
\ - [ 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
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
#! 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
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
[ 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
: 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 ;
: 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 ;
"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 ;
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
--- /dev/null
+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
"hashtables"
"strings"
"namespaces"
+ "generic"
"files"
"format"
"parser"
"threads"
"parsing-word"
"inference"
+ "dataflow"
"interpreter"
] [
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
[ { } ] [ 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
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 ;
: 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.
#include "memory.h"
#include "error.h"
-#include "gc.h"
#include "types.h"
+#include "gc.h"
#include "boolean.h"
#include "word.h"
#include "run.h"
--- /dev/null
+IN: kernel
+: version "0.69" ;
projects / factor.git / commitdiff