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

reworked bootstrap code, a lot of cleanups

cvs
Slava Pestov 2004-12-15 21:57:29 +00:00
parent daac96e764
commit 6c6c23ce71
41 changed files with 796 additions and 926 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
examples/more-random.factor
View File

@ -5,6 +5,13 @@ USE: math
USE: test USE: test
USE: namespaces USE: namespaces
: nth ( n list -- list[n] )
#! nth element of a proper list.
#! Supplying n <= 0 pushes the first element of the list.
#! Supplying an argument beyond the end of the list raises
#! an error.
swap [ cdr ] times car ;
: random-element ( list -- random ) : random-element ( list -- random )
#! Returns a random element from the given list. #! Returns a random element from the given list.
dup >r length pred 0 swap random-int r> nth ; dup >r length pred 0 swap random-int r> nth ;
@ -85,4 +92,8 @@ USE: namespaces
"random-pairs" get "random-pairs" get
check-random-subset check-random-subset
] unit-test ] unit-test
[ 1 ] [ -1 [ 1 2 ] nth ] unit-test
[ 1 ] [ 0 [ 1 2 ] nth ] unit-test
[ 2 ] [ 1 [ 1 2 ] nth ] unit-test
] with-scope ] with-scope

64
factor/jedit/FactorPlugin.java
View File

@ -170,15 +170,40 @@ public class FactorPlugin extends EditPlugin
getExternalInstance().eval(cmd); getExternalInstance().eval(cmd);
} //}}} } //}}}
//{{{ lookupWord() method
/**
* Look up the given Factor word in the vocabularies USE:d in the given view.
*/
public static FactorWord lookupWord(View view, String word)
{
SideKickParsedData data = SideKickParsedData.getParsedData(view);
if(data instanceof FactorParsedData)
{
FactorParsedData fdata = (FactorParsedData)data;
return getExternalInstance().searchVocabulary(fdata.use,word);
}
else
return null;
} //}}}
//{{{ factorWord() method //{{{ factorWord() method
/** /**
* Build a Factor expression for pushing the selected word on the stack * Look up the given Factor word in the vocabularies USE:d in the given view.
*/ */
public static String factorWord(FactorWord word) public static String factorWord(View view, String word)
{ {
return FactorReader.unparseObject(word.name) SideKickParsedData data = SideKickParsedData
+ " [ " + FactorReader.unparseObject(word.vocabulary) .getParsedData(view);
+ " ] search"; if(data instanceof FactorParsedData)
{
FactorParsedData fdata = (FactorParsedData)data;
return "\""
+ FactorReader.charsToEscapes(word)
+ "\" " + FactorReader.unparseObject(fdata.use)
+ " search";
}
else
return null;
} //}}} } //}}}
//{{{ factorWord() method //{{{ factorWord() method
@ -188,21 +213,22 @@ public class FactorPlugin extends EditPlugin
public static String factorWord(View view) public static String factorWord(View view)
{ {
JEditTextArea textArea = view.getTextArea(); JEditTextArea textArea = view.getTextArea();
SideKickParsedData data = SideKickParsedData String word = FactorPlugin.getWordAtCaret(textArea);
.getParsedData(view); if(word == null)
if(data instanceof FactorParsedData)
{
FactorParsedData fdata = (FactorParsedData)data;
String word = FactorPlugin.getWordAtCaret(textArea);
if(word == null)
return null;
return "\""
+ FactorReader.charsToEscapes(word)
+ "\" " + FactorReader.unparseObject(fdata.use)
+ " search";
}
else
return null; return null;
else
return factorWord(view,word);
} //}}}
//{{{ factorWord() method
/**
* Build a Factor expression for pushing the selected word on the stack
*/
public static String factorWord(FactorWord word)
{
return FactorReader.unparseObject(word.name)
+ " [ " + FactorReader.unparseObject(word.vocabulary)
+ " ] search";
} //}}} } //}}}
//{{{ factorWordOutputOp() method //{{{ factorWordOutputOp() method

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

@ -32,6 +32,7 @@ USE: parser
USE: stdio USE: stdio
"Cold boot in progress..." print "Cold boot in progress..." print
[ [
"/version.factor" "/version.factor"
"/library/stack.factor" "/library/stack.factor"
@ -41,7 +42,6 @@ USE: stdio
"/library/generic/builtin.factor" "/library/generic/builtin.factor"
"/library/generic/predicate.factor" "/library/generic/predicate.factor"
"/library/generic/traits.factor" "/library/generic/traits.factor"
"/library/types.factor"
"/library/math/math.factor" "/library/math/math.factor"
"/library/cons.factor" "/library/cons.factor"
"/library/combinators.factor" "/library/combinators.factor"
@ -117,6 +117,7 @@ USE: stdio
"/library/compiler/xt.factor" "/library/compiler/xt.factor"
"/library/compiler/optimizer.factor" "/library/compiler/optimizer.factor"
"/library/compiler/linearizer.factor" "/library/compiler/linearizer.factor"
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor" "/library/compiler/generator.factor"
"/library/compiler/compiler.factor" "/library/compiler/compiler.factor"
"/library/compiler/alien-types.factor" "/library/compiler/alien-types.factor"
@ -131,7 +132,6 @@ USE: stdio
"/library/sdl/hsv.factor" "/library/sdl/hsv.factor"
"/library/bootstrap/image.factor" "/library/bootstrap/image.factor"
"/library/bootstrap/cross-compiler.factor"
"/library/httpd/url-encoding.factor" "/library/httpd/url-encoding.factor"
"/library/httpd/html-tags.factor" "/library/httpd/html-tags.factor"

111
library/bootstrap/boot.factor
View File

@ -32,57 +32,66 @@ USE: namespaces
USE: stdio USE: stdio
USE: kernel USE: kernel
USE: vectors USE: vectors
USE: words
USE: hashtables
primitives, "/library/bootstrap/primitives.factor" run-resource
[ "/version.factor" run-resource
"/version.factor" "/library/stack.factor" run-resource
"/library/stack.factor" "/library/combinators.factor" run-resource
"/library/kernel.factor" "/library/kernel.factor" run-resource
"/library/generic/generic.factor" "/library/logic.factor" run-resource
"/library/generic/object.factor" "/library/cons.factor" run-resource
"/library/generic/builtin.factor" "/library/assoc.factor" run-resource
"/library/generic/predicate.factor" "/library/math/generic.factor" run-resource
"/library/generic/traits.factor" "/library/words.factor" run-resource
"/library/types.factor" "/library/math/arithmetic.factor" run-resource
"/library/combinators.factor" "/library/math/math-combinators.factor" run-resource
"/library/math/math.factor" "/library/math/math.factor" run-resource
"/library/cons.factor" "/library/lists.factor" run-resource
"/library/logic.factor" "/library/vectors.factor" run-resource
"/library/vectors.factor" "/library/strings.factor" run-resource
"/library/lists.factor" "/library/hashtables.factor" run-resource
"/library/assoc.factor" "/library/namespaces.factor" run-resource
"/library/math/arithmetic.factor" "/library/list-namespaces.factor" run-resource
"/library/math/math-combinators.factor" "/library/sbuf.factor" run-resource
"/library/strings.factor" "/library/errors.factor" run-resource
"/library/hashtables.factor" "/library/continuations.factor" run-resource
"/library/namespaces.factor" "/library/threads.factor" run-resource
"/library/list-namespaces.factor" "/library/io/stream.factor" run-resource
"/library/sbuf.factor" "/library/io/stdio.factor" run-resource
"/library/continuations.factor" "/library/io/io-internals.factor" run-resource
"/library/errors.factor" "/library/io/stream-impl.factor" run-resource
"/library/threads.factor" "/library/vocabularies.factor" run-resource
"/library/io/stream.factor" "/library/syntax/parse-numbers.factor" run-resource
"/library/io/io-internals.factor" "/library/syntax/parser.factor" run-resource
"/library/io/stream-impl.factor" "/library/syntax/parse-stream.factor" run-resource
"/library/io/stdio.factor"
"/library/words.factor"
"/library/vocabularies.factor"
"/library/syntax/parse-numbers.factor"
"/library/syntax/parser.factor"
"/library/syntax/parse-syntax.factor"
"/library/syntax/parse-stream.factor"
"/library/math/generic.factor"
"/library/bootstrap/init.factor"
] [
cross-compile-resource
] each
IN: init ! A bootstrapping trick. See doc/bootstrap.txt.
DEFER: boot vocabularies get [
"generic" off
] bind
[ "/library/generic/generic.factor" run-resource
boot "/library/generic/object.factor" run-resource
"Good morning!" print "/library/generic/builtin.factor" run-resource
flush "/library/generic/predicate.factor" run-resource
"/library/bootstrap/boot-stage2.factor" run-resource "/library/generic/traits.factor" run-resource
] boot-quot set
"/library/bootstrap/init.factor" run-resource
! A bootstrapping trick. See doc/bootstrap.txt.
"/library/syntax/parse-syntax.factor" run-resource
vocabularies get [
"!syntax" get "syntax" set
"!syntax" off
"syntax" get [
cdr dup word? [
"syntax" "vocabulary" set-word-property
] [
drop
] ifte
] hash-each
] bind

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

@ -1,431 +0,0 @@
! :folding=none: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.
USE: errors
USE: kernel
USE: lists
USE: math
USE: math-internals
USE: namespaces
USE: parser
USE: stdio
USE: streams
USE: strings
USE: vectors
USE: words
IN: alien
DEFER: dlopen
DEFER: dlsym
DEFER: dlsym-self
DEFER: dlclose
DEFER: <alien>
DEFER: <local-alien>
DEFER: alien-cell
DEFER: set-alien-cell
DEFER: alien-4
DEFER: set-alien-4
DEFER: alien-2
DEFER: set-alien-2
DEFER: alien-1
DEFER: set-alien-1
IN: compiler
DEFER: set-compiled-byte
DEFER: set-compiled-cell
DEFER: compiled-offset
DEFER: set-compiled-offset
DEFER: literal-top
DEFER: set-literal-top
IN: kernel
DEFER: gc-time
DEFER: getenv
DEFER: setenv
DEFER: save-image
DEFER: room
DEFER: os-env
DEFER: type
DEFER: size
DEFER: address
DEFER: heap-stats
DEFER: drop
DEFER: dup
DEFER: over
DEFER: pick
DEFER: swap
DEFER: >r
DEFER: r>
DEFER: ifte
DEFER: call
DEFER: datastack
DEFER: callstack
DEFER: set-datastack
DEFER: set-callstack
IN: strings
DEFER: str=
DEFER: str-hashcode
DEFER: sbuf=
DEFER: sbuf-hashcode
DEFER: sbuf-clone
IN: files
DEFER: stat
DEFER: (directory)
DEFER: cwd
DEFER: cd
IN: io-internals
DEFER: open-file
DEFER: client-socket
DEFER: server-socket
DEFER: close-port
DEFER: add-accept-io-task
DEFER: accept-fd
DEFER: can-read-line?
DEFER: add-read-line-io-task
DEFER: read-line-fd-8
DEFER: can-read-count?
DEFER: add-read-count-io-task
DEFER: read-count-fd-8
DEFER: can-write?
DEFER: add-write-io-task
DEFER: write-fd-8
DEFER: add-copy-io-task
DEFER: pending-io-error
DEFER: next-io-task
IN: math
DEFER: fraction>
IN: math-internals
DEFER: arithmetic-type
DEFER: fixnum=
DEFER: fixnum+
DEFER: fixnum-
DEFER: fixnum*
DEFER: fixnum/i
DEFER: fixnum/f
DEFER: fixnum-mod
DEFER: fixnum/mod
DEFER: fixnum-bitand
DEFER: fixnum-bitor
DEFER: fixnum-bitxor
DEFER: fixnum-bitnot
DEFER: fixnum-shift
DEFER: fixnum<
DEFER: fixnum<=
DEFER: fixnum>
DEFER: fixnum>=
DEFER: bignum=
DEFER: bignum+
DEFER: bignum-
DEFER: bignum*
DEFER: bignum/i
DEFER: bignum/f
DEFER: bignum-mod
DEFER: bignum/mod
DEFER: bignum-bitand
DEFER: bignum-bitor
DEFER: bignum-bitxor
DEFER: bignum-bitnot
DEFER: bignum-shift
DEFER: bignum<
DEFER: bignum<=
DEFER: bignum>
DEFER: bignum>=
DEFER: float=
DEFER: float+
DEFER: float-
DEFER: float*
DEFER: float/f
DEFER: float<
DEFER: float<=
DEFER: float>
DEFER: float>=
DEFER: facos
DEFER: fasin
DEFER: fatan
DEFER: fatan2
DEFER: fcos
DEFER: fexp
DEFER: fcosh
DEFER: flog
DEFER: fpow
DEFER: fsin
DEFER: fsinh
DEFER: fsqrt
IN: parser
DEFER: str>float
IN: profiler
DEFER: call-profiling
DEFER: call-count
DEFER: set-call-count
DEFER: allot-profiling
DEFER: allot-count
DEFER: set-allot-count
IN: random
DEFER: init-random
DEFER: (random-int)
IN: words
DEFER: <word>
DEFER: word-hashcode
DEFER: word-xt
DEFER: set-word-xt
DEFER: word-primitive
DEFER: set-word-primitive
DEFER: word-parameter
DEFER: set-word-parameter
DEFER: word-plist
DEFER: set-word-plist
DEFER: compiled?
IN: unparser
DEFER: (unparse-float)
IN: image
: primitives, ( -- )
2 [
execute
call
ifte
cons
car
cdr
<vector>
vector-length
set-vector-length
vector-nth
set-vector-nth
str-length
str-nth
str-compare
str=
str-hashcode
index-of*
substring
str-reverse
<sbuf>
sbuf-length
set-sbuf-length
sbuf-nth
set-sbuf-nth
sbuf-append
sbuf>str
sbuf-reverse
sbuf-clone
sbuf=
sbuf-hashcode
arithmetic-type
number?
>fixnum
>bignum
>float
numerator
denominator
fraction>
str>float
(unparse-float)
float>bits
real
imaginary
rect>
fixnum=
fixnum+
fixnum-
fixnum*
fixnum/i
fixnum/f
fixnum-mod
fixnum/mod
fixnum-bitand
fixnum-bitor
fixnum-bitxor
fixnum-bitnot
fixnum-shift
fixnum<
fixnum<=
fixnum>
fixnum>=
bignum=
bignum+
bignum-
bignum*
bignum/i
bignum/f
bignum-mod
bignum/mod
bignum-bitand
bignum-bitor
bignum-bitxor
bignum-bitnot
bignum-shift
bignum<
bignum<=
bignum>
bignum>=
float=
float+
float-
float*
float/f
float<
float<=
float>
float>=
facos
fasin
fatan
fatan2
fcos
fexp
fcosh
flog
fpow
fsin
fsinh
fsqrt
<word>
word-hashcode
word-xt
set-word-xt
word-primitive
set-word-primitive
word-parameter
set-word-parameter
word-plist
set-word-plist
call-profiling
call-count
set-call-count
allot-profiling
allot-count
set-allot-count
compiled?
drop
dup
swap
over
pick
>r
r>
eq?
getenv
setenv
open-file
stat
(directory)
garbage-collection
gc-time
save-image
datastack
callstack
set-datastack
set-callstack
exit*
client-socket
server-socket
close-port
add-accept-io-task
accept-fd
can-read-line?
add-read-line-io-task
read-line-fd-8
can-read-count?
add-read-count-io-task
read-count-fd-8
can-write?
add-write-io-task
write-fd-8
add-copy-io-task
pending-io-error
next-io-task
room
os-env
millis
init-random
(random-int)
type
size
cwd
cd
compiled-offset
set-compiled-offset
set-compiled-cell
set-compiled-byte
literal-top
set-literal-top
address
dlopen
dlsym
dlsym-self
dlclose
<alien>
<local-alien>
alien-cell
set-alien-cell
alien-4
set-alien-4
alien-2
set-alien-2
alien-1
set-alien-1
heap-stats
throw
] [
USE: stack swap succ tuck f define,
] each drop ;
: make-image ( name -- )
#! Make an image for the C interpreter.
[
"/library/bootstrap/boot.factor" run-resource
] with-image
swap write-image ;
: make-images ( -- )
"64-bits" off
"big-endian" off "boot.image.le32" make-image
"big-endian" on "boot.image.be32" make-image
"64-bits" on
"big-endian" off "boot.image.le64" make-image
"big-endian" on "boot.image.be64" make-image
"64-bits" off ;
: cross-compile-resource ( resource -- )
[
! Change behavior of ; and SYMBOL:
[ define, ] "define-hook" set
run-resource
] with-scope ;

145
library/bootstrap/image.factor
View File

@ -55,10 +55,7 @@ USE: test
USE: vectors USE: vectors
USE: unparser USE: unparser
USE: words USE: words
USE: parser
USE: stack
USE: combinators
USE: logic
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -193,24 +190,49 @@ M: f ' ( obj -- ptr )
( Words ) ( Words )
: word, ( word -- pointer ) : make-plist ( word -- plist )
word-tag here-as >r word-tag >header emit [
hashcode emit ( hashcode ) dup word-name "name" swons ,
0 emit r> ; dup word-vocabulary "vocabulary" swons ,
parsing? [ t "parsing" swons , ] when
] make-list ;
! This is to handle mutually recursive words : word, ( word -- )
[
word-tag >header ,
dup hashcode ,
0 ,
dup word-primitive ,
dup word-parameter ' ,
dup make-plist ' ,
0 ,
0 ,
] make-list
swap word-tag here-as pool-object
[ emit ] each ;
: word-error ( word msg -- )
[
,
dup word-vocabulary ,
" " ,
word-name ,
] make-string throw ;
: transfer-word ( word -- word )
#! This is a hack. See doc/bootstrap.txt.
dup dup word-name swap word-vocabulary unit search
dup [
nip
] [
drop "Missing DEFER: " word-error
] ifte ;
: fixup-word ( word -- offset ) : fixup-word ( word -- offset )
dup pooled-object dup [ dup pooled-object dup [
nip nip
] [ ] [
drop drop "Not in image: " word-error
[
"Not in image: " ,
dup word-vocabulary ,
" " ,
word-name ,
] make-string throw
] ifte ; ] ifte ;
: fixup-words ( -- ) : fixup-words ( -- )
@ -219,7 +241,7 @@ M: f ' ( obj -- ptr )
] vector-map image set ; ] vector-map image set ;
M: word ' ( word -- pointer ) M: word ' ( word -- pointer )
dup pooled-object dup [ nip ] [ drop ] ifte ; transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
( Conses ) ( Conses )
@ -263,40 +285,6 @@ M: string ' ( string -- pointer )
drop dup emit-string dup >r pool-object r> drop dup emit-string dup >r pool-object r>
] ifte ; ] ifte ;
( Word definitions )
: (vocabulary) ( name -- vocab )
#! Vocabulary for target image.
dup "vocabularies" get hash dup [
nip
] [
drop >r namespace-buckets <hashtable> dup r>
"vocabularies" get set-hash
] ifte ;
: (word+) ( word -- )
#! Add the word to a vocabulary in the target image.
dup word-name over word-vocabulary
(vocabulary) set-hash ;
: emit-plist ( word -- plist )
[
dup word-name "name" swons ,
dup word-vocabulary "vocabulary" swons ,
"parsing" word-property [ t "parsing" swons , ] when
] make-list ' ;
: define, ( word primitive parameter -- )
#! Write a word definition to the image.
' >r >r dup (word+) dup emit-plist >r
dup word, pool-object
r> ( -- plist )
r> ( primitive -- ) emit
r> ( parameter -- ) emit
( plist -- ) emit
0 emit ( padding )
0 emit ;
( Arrays and vectors ) ( Arrays and vectors )
: emit-array ( list -- pointer ) : emit-array ( list -- pointer )
@ -317,35 +305,29 @@ M: vector ' ( vector -- pointer )
( End of the image ) ( End of the image )
: vocabularies, ( -- ) : vocabularies, ( vocabularies -- )
#! Produces code with stack effect ( -- vocabularies ).
#! This code sets up vocabulary hash tables.
\ <namespace> ,
[ [
"vocabularies" get [ cdr dup vector? [
uncons hash>alist , \ alist>hash , , \ set , [
] hash-each cdr dup word? [ word, ] [ drop ] ifte
] make-list , ] hash-each
\ extend , ; ] [
drop
] ifte
] hash-each ;
: global, ( -- ) : global, ( -- )
#! Produces code with stack effect ( vocabularies -- ). vocabularies get
<namespace> ' global-offset fixup dup vocabularies,
"vocabularies" , <namespace> [ vocabularies set ] extend '
\ global , global-offset fixup ;
\ set-hash , ;
: hash-quot ( -- quot )
#! Generate a quotation to generate vocabulary and global
#! namespace hashtables.
[ vocabularies, global, ] make-list ;
: boot, ( quot -- ) : boot, ( quot -- )
boot-quot get append ' boot-quot-offset fixup ; boot-quot get ' boot-quot-offset fixup ;
: end ( -- ) : end ( -- )
hash-quot
boot, boot,
global,
fixup-words fixup-words
here base - heap-size-offset fixup ; here base - heap-size-offset fixup ;
@ -373,7 +355,6 @@ M: vector ' ( vector -- pointer )
[ [
300000 <vector> image set 300000 <vector> image set
521 <hashtable> "objects" set 521 <hashtable> "objects" set
namespace-buckets <hashtable> "vocabularies" set
! Note that this is a vector that we can side-effect, ! Note that this is a vector that we can side-effect,
! since ; ends up using this variable from nested ! since ; ends up using this variable from nested
! parser namespaces. ! parser namespaces.
@ -386,3 +367,21 @@ M: vector ' ( vector -- pointer )
[ begin call end ] with-minimal-image ; [ begin call end ] with-minimal-image ;
: test-image ( quot -- ) with-image vector>list . ; : test-image ( quot -- ) with-image vector>list . ;
: make-image ( name -- )
#! Make an image for the C interpreter.
[
"/library/bootstrap/boot.factor" run-resource
boot-quot set
] with-image
swap write-image ;
: make-images ( -- )
"64-bits" off
"big-endian" off "boot.image.le32" make-image
"big-endian" on "boot.image.be32" make-image
"64-bits" on
"big-endian" off "boot.image.le64" make-image
"big-endian" on "boot.image.be64" make-image
"64-bits" off ;

11
library/bootstrap/init.factor
View File

@ -26,8 +26,6 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init IN: init
USE: compiler
USE: errors
USE: kernel USE: kernel
USE: namespaces USE: namespaces
USE: parser USE: parser
@ -35,7 +33,6 @@ USE: stdio
USE: streams USE: streams
USE: threads USE: threads
USE: words USE: words
USE: vectors
: boot ( -- ) : boot ( -- )
#! Initialize an interpreter with the basic services. #! Initialize an interpreter with the basic services.
@ -43,5 +40,11 @@ USE: vectors
init-threads init-threads
init-stdio init-stdio
"HOME" os-env [ "." ] unless* "~" set "HOME" os-env [ "." ] unless* "~" set
"/" "/" set
init-search-path ; init-search-path ;
[
boot
"Good morning!" print
flush
"/library/bootstrap/boot-stage2.factor" run-resource
]

242
library/bootstrap/primitives.factor Normal file
View File

@ -0,0 +1,242 @@
! :folding=none: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: image
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: words
USE: vectors
USE: hashtables
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab
"generic" vocab
! This symbol needs the same hashcode in the target as in the
! host.
vocabularies
<namespace> vocabularies set
vocabularies get [
reveal
"generic" set
"syntax" set
] bind
2 [
[ "words" | "execute" ]
[ "kernel" | "call" ]
[ "kernel" | "ifte" ]
[ "lists" | "cons" ]
[ "lists" | "car" ]
[ "lists" | "cdr" ]
[ "vectors" | "<vector>" ]
[ "vectors" | "vector-length" ]
[ "vectors" | "set-vector-length" ]
[ "vectors" | "vector-nth" ]
[ "vectors" | "set-vector-nth" ]
[ "strings" | "str-length" ]
[ "strings" | "str-nth" ]
[ "strings" | "str-compare" ]
[ "strings" | "str=" ]
[ "strings" | "str-hashcode" ]
[ "strings" | "index-of*" ]
[ "strings" | "substring" ]
[ "strings" | "str-reverse" ]
[ "strings" | "<sbuf>" ]
[ "strings" | "sbuf-length" ]
[ "strings" | "set-sbuf-length" ]
[ "strings" | "sbuf-nth" ]
[ "strings" | "set-sbuf-nth" ]
[ "strings" | "sbuf-append" ]
[ "strings" | "sbuf>str" ]
[ "strings" | "sbuf-reverse" ]
[ "strings" | "sbuf-clone" ]
[ "strings" | "sbuf=" ]
[ "strings" | "sbuf-hashcode" ]
[ "math-internals" | "arithmetic-type" ]
[ "math" | "number?" ]
[ "math" | ">fixnum" ]
[ "math" | ">bignum" ]
[ "math" | ">float" ]
[ "math" | "numerator" ]
[ "math" | "denominator" ]
[ "math" | "fraction>" ]
[ "parser" | "str>float" ]
[ "unparser" | "(unparse-float)" ]
[ "math" | "float>bits" ]
[ "math" | "real" ]
[ "math" | "imaginary" ]
[ "math" | "rect>" ]
[ "math-internals" | "fixnum=" ]
[ "math-internals" | "fixnum+" ]
[ "math-internals" | "fixnum-" ]
[ "math-internals" | "fixnum*" ]
[ "math-internals" | "fixnum/i" ]
[ "math-internals" | "fixnum/f" ]
[ "math-internals" | "fixnum-mod" ]
[ "math-internals" | "fixnum/mod" ]
[ "math-internals" | "fixnum-bitand" ]
[ "math-internals" | "fixnum-bitor" ]
[ "math-internals" | "fixnum-bitxor" ]
[ "math-internals" | "fixnum-bitnot" ]
[ "math-internals" | "fixnum-shift" ]
[ "math-internals" | "fixnum<" ]
[ "math-internals" | "fixnum<=" ]
[ "math-internals" | "fixnum>" ]
[ "math-internals" | "fixnum>=" ]
[ "math-internals" | "bignum=" ]
[ "math-internals" | "bignum+" ]
[ "math-internals" | "bignum-" ]
[ "math-internals" | "bignum*" ]
[ "math-internals" | "bignum/i" ]
[ "math-internals" | "bignum/f" ]
[ "math-internals" | "bignum-mod" ]
[ "math-internals" | "bignum/mod" ]
[ "math-internals" | "bignum-bitand" ]
[ "math-internals" | "bignum-bitor" ]
[ "math-internals" | "bignum-bitxor" ]
[ "math-internals" | "bignum-bitnot" ]
[ "math-internals" | "bignum-shift" ]
[ "math-internals" | "bignum<" ]
[ "math-internals" | "bignum<=" ]
[ "math-internals" | "bignum>" ]
[ "math-internals" | "bignum>=" ]
[ "math-internals" | "float=" ]
[ "math-internals" | "float+" ]
[ "math-internals" | "float-" ]
[ "math-internals" | "float*" ]
[ "math-internals" | "float/f" ]
[ "math-internals" | "float<" ]
[ "math-internals" | "float<=" ]
[ "math-internals" | "float>" ]
[ "math-internals" | "float>=" ]
[ "math-internals" | "facos" ]
[ "math-internals" | "fasin" ]
[ "math-internals" | "fatan" ]
[ "math-internals" | "fatan2" ]
[ "math-internals" | "fcos" ]
[ "math-internals" | "fexp" ]
[ "math-internals" | "fcosh" ]
[ "math-internals" | "flog" ]
[ "math-internals" | "fpow" ]
[ "math-internals" | "fsin" ]
[ "math-internals" | "fsinh" ]
[ "math-internals" | "fsqrt" ]
[ "words" | "<word>" ]
[ "words" | "word-hashcode" ]
[ "words" | "word-xt" ]
[ "words" | "set-word-xt" ]
[ "words" | "word-primitive" ]
[ "words" | "set-word-primitive" ]
[ "words" | "word-parameter" ]
[ "words" | "set-word-parameter" ]
[ "words" | "word-plist" ]
[ "words" | "set-word-plist" ]
[ "profiler" | "call-profiling" ]
[ "profiler" | "call-count" ]
[ "profiler" | "set-call-count" ]
[ "profiler" | "allot-profiling" ]
[ "profiler" | "allot-count" ]
[ "profiler" | "set-allot-count" ]
[ "words" | "compiled?" ]
[ "kernel" | "drop" ]
[ "kernel" | "dup" ]
[ "kernel" | "swap" ]
[ "kernel" | "over" ]
[ "kernel" | "pick" ]
[ "kernel" | ">r" ]
[ "kernel" | "r>" ]
[ "kernel" | "eq?" ]
[ "kernel" | "getenv" ]
[ "kernel" | "setenv" ]
[ "io-internals" | "open-file" ]
[ "files" | "stat" ]
[ "files" | "(directory)" ]
[ "kernel" | "garbage-collection" ]
[ "kernel" | "gc-time" ]
[ "kernel" | "save-image" ]
[ "kernel" | "datastack" ]
[ "kernel" | "callstack" ]
[ "kernel" | "set-datastack" ]
[ "kernel" | "set-callstack" ]
[ "kernel" | "exit*" ]
[ "io-internals" | "client-socket" ]
[ "io-internals" | "server-socket" ]
[ "io-internals" | "close-port" ]
[ "io-internals" | "add-accept-io-task" ]
[ "io-internals" | "accept-fd" ]
[ "io-internals" | "can-read-line?" ]
[ "io-internals" | "add-read-line-io-task" ]
[ "io-internals" | "read-line-fd-8" ]
[ "io-internals" | "can-read-count?" ]
[ "io-internals" | "add-read-count-io-task" ]
[ "io-internals" | "read-count-fd-8" ]
[ "io-internals" | "can-write?" ]
[ "io-internals" | "add-write-io-task" ]
[ "io-internals" | "write-fd-8" ]
[ "io-internals" | "add-copy-io-task" ]
[ "io-internals" | "pending-io-error" ]
[ "io-internals" | "next-io-task" ]
[ "kernel" | "room" ]
[ "kernel" | "os-env" ]
[ "kernel" | "millis" ]
[ "random" | "init-random" ]
[ "random" | "(random-int)" ]
[ "kernel" | "type" ]
[ "kernel" | "size" ]
[ "files" | "cwd" ]
[ "files" | "cd" ]
[ "compiler" | "compiled-offset" ]
[ "compiler" | "set-compiled-offset" ]
[ "compiler" | "set-compiled-cell" ]
[ "compiler" | "set-compiled-byte" ]
[ "compiler" | "literal-top" ]
[ "compiler" | "set-literal-top" ]
[ "kernel" | "address" ]
[ "alien" | "dlopen" ]
[ "alien" | "dlsym" ]
[ "alien" | "dlsym-self" ]
[ "alien" | "dlclose" ]
[ "alien" | "<alien>" ]
[ "alien" | "<local-alien>" ]
[ "alien" | "alien-cell" ]
[ "alien" | "set-alien-cell" ]
[ "alien" | "alien-4" ]
[ "alien" | "set-alien-4" ]
[ "alien" | "alien-2" ]
[ "alien" | "set-alien-2" ]
[ "alien" | "alien-1" ]
[ "alien" | "set-alien-1" ]
[ "kernel" | "heap-stats" ]
[ "errors" | "throw" ]
] [
unswons create swap succ [ f define ] keep
] each drop

2
library/cli.factor
View File

@ -50,7 +50,7 @@ USE: words
: run-user-init ( -- ) : run-user-init ( -- )
#! Run user init file if it exists #! Run user init file if it exists
"user-init" get [ "user-init" get [
[ "~" get , "/" get , ".factor-" , "rc" , ] make-string [ "~" get , "/" , ".factor-" , "rc" , ] make-string
?run-file ?run-file
] when ; ] when ;

1
library/combinators.factor
View File

@ -51,6 +51,7 @@ USE: lists
#! Apply code to input. #! Apply code to input.
swap dup >r call r> swap ; inline swap dup >r call r> swap ; inline
IN: lists DEFER: uncons IN: kernel
: cond ( x list -- ) : cond ( x list -- )
#! The list is of this form: #! The list is of this form:
#! #!

4
library/compiler/alien.factor
View File

@ -28,6 +28,7 @@
IN: alien IN: alien
USE: compiler USE: compiler
USE: errors USE: errors
USE: generic
USE: inference USE: inference
USE: interpreter USE: interpreter
USE: kernel USE: kernel
@ -37,6 +38,9 @@ USE: namespaces
USE: parser USE: parser
USE: words USE: words
BUILTIN: dll 15
BUILTIN: alien 16
: library ( name -- handle ) : library ( name -- handle )
"libraries" get [ "libraries" get [
dup get dup dll? [ dup get dup dll? [

2
library/compiler/linearizer.factor
View File

@ -99,7 +99,7 @@ SYMBOL: #target ( part of jump table )
gensym dup t "label" set-word-property ; gensym dup t "label" set-word-property ;
: label? ( obj -- ? ) : label? ( obj -- ? )
dup word ? [ "label" word-property ] [ drop f ] ifte ; dup word? [ "label" word-property ] [ drop f ] ifte ;
: label, ( label -- ) : label, ( label -- )
#label swons , ; #label swons , ;

57
library/cons.factor
View File

@ -26,8 +26,15 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lists IN: lists
USE: generic
USE: kernel USE: kernel
! This file contains vital list-related words that everything
! else depends on, and is loaded early in bootstrap.
! lists.factor has everything else.
BUILTIN: cons 2
: swons ( cdr car -- [ car | cdr ] ) : swons ( cdr car -- [ car | cdr ] )
#! Push a new cons cell. If the cdr is f or a proper list, #! Push a new cons cell. If the cdr is f or a proper list,
#! has the effect of prepending the car to the cdr. #! has the effect of prepending the car to the cdr.
@ -50,3 +57,53 @@ USE: kernel
: 2cdr ( cons cons -- car car ) : 2cdr ( cons cons -- car car )
swap cdr swap cdr ; swap cdr swap cdr ;
: last* ( list -- last )
#! Last cons of a list.
dup cdr cons? [ cdr last* ] when ;
: last ( list -- last )
#! Last element of a list.
last* car ;
: tail ( list -- tail )
#! Return the cdr of the last cons cell, or f.
dup [ last* cdr ] when ;
: list? ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup cons? [ tail ] when not ;
: all? ( list pred -- ? )
#! Push if the predicate returns true for each element of
#! the list.
over [
dup >r swap uncons >r swap call [
r> r> all?
] [
r> drop r> drop f
] ifte
] [
2drop t
] ifte ; inline
: (each) ( list quot -- list quot )
>r uncons r> tuck 2slip ; inline
: each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
#! quotation with effect ( X -- ) to each element.
over [ (each) each ] [ 2drop ] ifte ; inline
: subset ( list quot -- list )
#! Applies a quotation with effect ( X -- ? ) to each
#! element of a list; all elements for which the quotation
#! returned a value other than f are collected in a new
#! list.
over [
over car >r (each)
rot >r subset r> [ r> swons ] [ r> drop ] ifte
] [
drop
] ifte ; inline

3
library/errors.factor
View File

@ -25,6 +25,9 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
DEFER: callcc1
IN: errors IN: errors
USE: kernel USE: kernel
USE: lists USE: lists

3
library/generic/generic.factor
View File

@ -55,6 +55,9 @@ USE: vectors
! - metaclass: a metaclass is a symbol with a handful of word ! - metaclass: a metaclass is a symbol with a handful of word
! properties: "define-method" "builtin-types" ! properties: "define-method" "builtin-types"
: undefined-method
"No applicable method." throw ;
: metaclass ( class -- metaclass ) : metaclass ( class -- metaclass )
"metaclass" word-property ; "metaclass" word-property ;

3
library/generic/traits.factor
View File

@ -68,9 +68,6 @@ SYMBOL: delegate
: init-traits-map ( word -- ) : init-traits-map ( word -- )
<namespace> "traits-map" set-word-property ; <namespace> "traits-map" set-word-property ;
: undefined-method
"No applicable method." throw ;
: traits-dispatch ( selector traits -- traits quot ) : traits-dispatch ( selector traits -- traits quot )
#! Look up the method with the traits object on the stack. #! Look up the method with the traits object on the stack.
#! Returns the traits to call the method on; either the #! Returns the traits to call the method on; either the

24
library/hashtables.factor
View File

@ -93,3 +93,27 @@ PREDICATE: vector hashtable ( obj -- ? )
: alist>hash ( alist -- hash ) : alist>hash ( alist -- hash )
37 <hashtable> swap [ unswons pick set-hash ] each ; 37 <hashtable> swap [ unswons pick set-hash ] each ;
: hash-map ( hash code -- hash )
#! Apply the code to each key/value pair of the hashtable,
#! collecting return values in a new hashtable.
>r hash>alist r> map alist>hash ;
! In case I break hashing:
! : hash ( key table -- value )
! hash>alist assoc ;
!
! : set-hash ( value key table -- )
! dup vector-length [
! ( value key table index )
! >r 3dup r>
! ( value key table value key table index )
! [
! swap vector-nth
! ( value key table value key alist )
! set-assoc
! ] keep
! ( value key table new-assoc index )
! pick set-vector-nth
! ] times* 3drop ;

2
library/io/files.factor
View File

@ -42,7 +42,7 @@ USE: strings
: directory ( dir -- list ) : directory ( dir -- list )
#! List a directory. #! List a directory.
(directory) str-sort ; (directory) [ str-lexi> ] sort ;
: file-length ( file -- length ) : file-length ( file -- length )
stat dup [ cdr cdr car ] when ; stat dup [ cdr cdr car ] when ;

3
library/io/io-internals.factor
View File

@ -26,11 +26,14 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: io-internals IN: io-internals
USE: generic
USE: kernel USE: kernel
USE: namespaces USE: namespaces
USE: strings USE: strings
USE: threads USE: threads
BUILTIN: port 14
: stdin 0 getenv ; : stdin 0 getenv ;
: stdout 1 getenv ; : stdout 1 getenv ;

6
library/io/stream.factor
View File

@ -42,12 +42,12 @@ GENERIC: fclose ( stream -- )
: fread1 ( stream -- string ) : fread1 ( stream -- string )
1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ; 1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ;
: fprint ( string stream -- )
tuck fwrite "\n" over fwrite fauto-flush ;
: fwrite ( string stream -- ) : fwrite ( string stream -- )
f swap fwrite-attr ; f swap fwrite-attr ;
: fprint ( string stream -- )
tuck fwrite "\n" over fwrite fauto-flush ;
TRAITS: string-output-stream TRAITS: string-output-stream
M: string-output-stream fwrite-attr ( string style stream -- ) M: string-output-stream fwrite-attr ( string style stream -- )

13
library/kernel.factor
View File

@ -25,10 +25,19 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: syntax
USE: generic
BUILTIN: f 6 FORGET: f?
BUILTIN: t 7 FORGET: t?
IN: vectors IN: vectors
DEFER: vector= DEFER: vector=
DEFER: vector-hashcode DEFER: vector-hashcode
IN: lists
DEFER: cons=
DEFER: cons-hashcode
IN: kernel IN: kernel
USE: lists USE: lists
USE: math USE: math
@ -108,3 +117,7 @@ IN: kernel
: set-boot ( quot -- ) : set-boot ( quot -- )
#! Set the boot quotation. #! Set the boot quotation.
8 setenv ; 8 setenv ;
: num-types ( -- n )
#! One more than the maximum value from type primitive.
17 ;

70
library/lists.factor
View File

@ -56,30 +56,6 @@ USE: vectors
#! Test if a list contains an element. #! Test if a list contains an element.
[ over = ] some? >boolean nip ; [ over = ] some? >boolean nip ;
: nth ( n list -- list[n] )
#! nth element of a proper list.
#! Supplying n <= 0 pushes the first element of the list.
#! Supplying an argument beyond the end of the list raises
#! an error.
swap [ cdr ] times car ;
: last* ( list -- last )
#! Last cons of a list.
dup cdr cons? [ cdr last* ] when ;
: last ( list -- last )
#! Last element of a list.
last* car ;
: tail ( list -- tail )
#! Return the cdr of the last cons cell, or f.
dup [ last* cdr ] when ;
: list? ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup cons? [ tail ] when not ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 ) : partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
rot [ swapd cons ] [ >r cons r> ] ifte ; rot [ swapd cons ] [ >r cons r> ] ifte ;
@ -109,10 +85,6 @@ USE: vectors
drop drop
] ifte ; inline ] ifte ; inline
: num-sort ( list -- sorted )
#! Sorts the list into ascending numerical order.
[ > ] sort ;
! Redefined below ! Redefined below
DEFER: tree-contains? DEFER: tree-contains?
@ -140,14 +112,6 @@ DEFER: tree-contains?
#! list. #! list.
2dup contains? [ nip ] [ cons ] ifte ; 2dup contains? [ nip ] [ cons ] ifte ;
: (each) ( list quot -- list quot )
>r uncons r> tuck 2slip ; inline
: each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
#! quotation with effect ( X -- ) to each element.
over [ (each) each ] [ 2drop ] ifte ; inline
: reverse ( list -- list ) : reverse ( list -- list )
[ ] swap [ swons ] each ; [ ] swap [ swons ] each ;
@ -157,18 +121,6 @@ DEFER: tree-contains?
#! ( X -- Y ) to each element into a new list. #! ( X -- Y ) to each element into a new list.
over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline
: subset ( list quot -- list )
#! Applies a quotation with effect ( X -- ? ) to each
#! element of a list; all elements for which the quotation
#! returned a value other than f are collected in a new
#! list.
over [
over car >r (each)
rot >r subset r> [ r> swons ] [ r> drop ] ifte
] [
drop
] ifte ; inline
: remove ( obj list -- list ) : remove ( obj list -- list )
#! Remove all occurrences of the object from the list. #! Remove all occurrences of the object from the list.
[ dupd = not ] subset nip ; [ dupd = not ] subset nip ;
@ -182,19 +134,6 @@ DEFER: tree-contains?
uncons prune 2dup contains? [ nip ] [ cons ] ifte uncons prune 2dup contains? [ nip ] [ cons ] ifte
] when ; ] when ;
: all? ( list pred -- ? )
#! Push if the predicate returns true for each element of
#! the list.
over [
dup >r swap uncons >r swap call [
r> r> all?
] [
r> drop r> drop f
] ifte
] [
2drop t
] ifte ; inline
: all=? ( list -- ? ) : all=? ( list -- ? )
#! Check if all elements of a list are equal. #! Check if all elements of a list are equal.
dup [ uncons [ over = ] all? nip ] [ drop t ] ifte ; dup [ uncons [ over = ] all? nip ] [ drop t ] ifte ;
@ -241,15 +180,6 @@ DEFER: tree-contains?
: cons-hashcode ( cons -- hash ) : cons-hashcode ( cons -- hash )
4 (cons-hashcode) ; 4 (cons-hashcode) ;
: list>vector ( list -- vector )
dup length <vector> swap [ over vector-push ] each ;
: stack>list ( vector -- list )
[ ] swap [ swons ] vector-each ;
: vector>list ( vector -- list )
stack>list reverse ;
: project ( n quot -- list ) : project ( n quot -- list )
#! Execute the quotation n times, passing the loop counter #! Execute the quotation n times, passing the loop counter
#! the quotation as it ranges from 0..n-1. Collect results #! the quotation as it ranges from 0..n-1. Collect results

20
library/math/generic.factor
View File

@ -32,7 +32,27 @@ USE: kernel
USE: vectors USE: vectors
USE: words USE: words
BUILTIN: fixnum 0
BUILTIN: ratio 4
BUILTIN: complex 5
BUILTIN: bignum 9
BUILTIN: float 10
DEFER: number= DEFER: number=
DEFER: mod
DEFER: abs
DEFER: <
DEFER: <=
DEFER: >
DEFER: >=
DEFER: neg
DEFER: /i
DEFER: *
DEFER: +
DEFER: -
DEFER: /
DEFER: /f
DEFER: sq
: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ; : (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ; : gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;

2
library/namespaces.factor
View File

@ -70,7 +70,7 @@ USE: vectors
: set-global ( g -- ) 4 setenv ; : set-global ( g -- ) 4 setenv ;
: init-namespaces ( -- ) : init-namespaces ( -- )
global >n global "global" set ; global >n ;
: namespace-buckets 23 ; : namespace-buckets 23 ;

13
library/sdl/hsv.factor
View File

@ -11,24 +11,25 @@ USE: kernel
USE: lists USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
USE: vectors
: f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ; : f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
: p ( v s x -- v p x ) >r dupd neg succ * r> ; : p ( v s x -- v p x ) >r dupd neg succ * r> ;
: q ( v s f -- q ) * neg succ * ; : q ( v s f -- q ) * neg succ * ;
: t_ ( v s f -- t_ ) neg succ * neg succ * ; : t_ ( v s f -- t_ ) neg succ * neg succ * ;
: mod-cond ( p list -- ) : mod-cond ( p vector -- )
#! Call p mod q'th entry of the list of quotations, where #! Call p mod q'th entry of the vector of quotations, where
#! q is the length of the list. The value q remains on the #! q is the length of the vector. The value q remains on the
#! stack. #! stack.
[ dupd length mod ] keep nth call ; [ dupd length mod ] keep vector-nth call ;
: hsv>rgb ( h s v -- r g b ) : hsv>rgb ( h s v -- r g b )
pick 6 * >fixnum [ pick 6 * >fixnum {
[ f_ t_ p swap ( v p t ) ] [ f_ t_ p swap ( v p t ) ]
[ f_ q p -rot ( q v p ) ] [ f_ q p -rot ( q v p ) ]
[ f_ t_ p swapd ( p v t ) ] [ f_ t_ p swapd ( p v t ) ]
[ f_ q p rot ( p q v ) ] [ f_ q p rot ( p q v ) ]
[ f_ t_ p swap rot ( t p v ) ] [ f_ t_ p swap rot ( t p v ) ]
[ f_ q p ( v p q ) ] [ f_ q p ( v p q ) ]
] mod-cond ; } mod-cond ;

9
library/strings.factor
View File

@ -26,10 +26,14 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: strings IN: strings
USE: generic
USE: kernel USE: kernel
USE: lists USE: lists
USE: math USE: math
BUILTIN: string 12
BUILTIN: sbuf 13
: f-or-"" ( obj -- ? ) : f-or-"" ( obj -- ? )
dup not swap "" = or ; dup not swap "" = or ;
@ -132,11 +136,6 @@ USE: math
-rot 2dup >r >r >r str-nth r> call r> r> -rot 2dup >r >r >r str-nth r> call r> r>
] times* 2drop ; inline ] times* 2drop ; inline
: str-sort ( list -- sorted )
#! Sorts the list into ascending lexicographical string
#! order.
[ str-lexi> ] sort ;
: blank? ( ch -- ? ) " \t\n\r" str-contains? ; : blank? ( ch -- ? ) " \t\n\r" str-contains? ;
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; : letter? ( ch -- ? ) CHAR: a CHAR: z between? ;
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ;

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

@ -25,7 +25,9 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: parser ! Bootstrapping trick; see doc/bootstrap.txt.
IN: !syntax
USE: syntax
USE: errors USE: errors
USE: hashtables USE: hashtables
@ -33,82 +35,17 @@ USE: kernel
USE: lists USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
USE: parser
USE: strings USE: strings
USE: words USE: words
USE: vectors USE: vectors
USE: unparser USE: unparser
! Colon defs : parsing ( -- )
: CREATE ( -- word ) #! Mark the most recently defined word to execute at parse
scan "in" get create dup set-word #! time, rather than run time. The word can use 'scan' to
dup f "documentation" set-word-property #! read ahead in the input stream.
dup f "stack-effect" set-word-property word t "parsing" set-word-property ; parsing
dup "line-number" get "line" set-word-property
dup "col" get "col" set-word-property
dup "file" get "file" set-word-property ;
! \x
: unicode-escape>ch ( -- esc )
#! Read \u....
next-ch digit> 16 *
next-ch digit> + 16 *
next-ch digit> + 16 *
next-ch digit> + ;
: ascii-escape>ch ( ch -- esc )
[
[ CHAR: e | CHAR: \e ]
[ CHAR: n | CHAR: \n ]
[ CHAR: r | CHAR: \r ]
[ CHAR: t | CHAR: \t ]
[ CHAR: s | CHAR: \s ]
[ CHAR: \s | CHAR: \s ]
[ CHAR: 0 | CHAR: \0 ]
[ CHAR: \\ | CHAR: \\ ]
[ CHAR: \" | CHAR: \" ]
] assoc ;
: escape ( ch -- esc )
dup CHAR: u = [
drop unicode-escape>ch
] [
ascii-escape>ch
] ifte ;
: parse-escape ( -- )
next-ch escape dup [ drop "Bad escape" throw ] unless ;
: parse-ch ( ch -- ch )
dup CHAR: \\ = [ drop parse-escape ] when ;
: doc-comment-here? ( parsed -- ? )
not "in-definition" get and ;
: parsed-stack-effect ( parsed str -- parsed )
over doc-comment-here? [
word stack-effect [
drop
] [
word swap "stack-effect" set-word-property
] ifte
] [
drop
] ifte ;
: documentation+ ( word str -- )
over "documentation" word-property [
swap "\n" swap cat3
] when*
"documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [
word swap documentation+
] [
drop
] ifte ;
IN: syntax
: inline ( -- ) : inline ( -- )
#! Mark the last word to be inlined. #! Mark the last word to be inlined.

78
library/syntax/parser.factor
View File

@ -79,7 +79,7 @@ USE: unparser
] ifte ] ifte
] [ ] [
r> drop nip str-length r> drop nip str-length
] ifte ; ] ifte ; inline
: skip-blank ( n line -- n ) : skip-blank ( n line -- n )
[ blank? not ] skip ; [ blank? not ] skip ;
@ -179,15 +179,71 @@ USE: unparser
: next-word-ch ( -- ch ) : next-word-ch ( -- ch )
"col" get "line" get skip-blank "col" set next-ch ; "col" get "line" get skip-blank "col" set next-ch ;
IN: syntax : CREATE ( -- word )
scan "in" get create dup set-word
dup f "documentation" set-word-property
dup f "stack-effect" set-word-property
dup "line-number" get "line" set-word-property
dup "col" get "col" set-word-property
dup "file" get "file" set-word-property ;
: parsing ( -- ) ! \x
#! Mark the most recently defined word to execute at parse : unicode-escape>ch ( -- esc )
#! time, rather than run time. The word can use 'scan' to #! Read \u....
#! read ahead in the input stream. next-ch digit> 16 *
word t "parsing" set-word-property ; next-ch digit> + 16 *
next-ch digit> + 16 *
next-ch digit> + ;
! Once this file has loaded, we can use 'parsing' normally. : ascii-escape>ch ( ch -- esc )
! This hack is needed because in Java Factor, 'parsing' is [
! not parsing, but in CFactor, it is. [ CHAR: e | CHAR: \e ]
\ parsing t "parsing" set-word-property [ CHAR: n | CHAR: \n ]
[ CHAR: r | CHAR: \r ]
[ CHAR: t | CHAR: \t ]
[ CHAR: s | CHAR: \s ]
[ CHAR: \s | CHAR: \s ]
[ CHAR: 0 | CHAR: \0 ]
[ CHAR: \\ | CHAR: \\ ]
[ CHAR: \" | CHAR: \" ]
] assoc ;
: escape ( ch -- esc )
dup CHAR: u = [
drop unicode-escape>ch
] [
ascii-escape>ch
] ifte ;
: parse-escape ( -- )
next-ch escape dup [ drop "Bad escape" throw ] unless ;
: parse-ch ( ch -- ch )
dup CHAR: \\ = [ drop parse-escape ] when ;
: doc-comment-here? ( parsed -- ? )
not "in-definition" get and ;
: parsed-stack-effect ( parsed str -- parsed )
over doc-comment-here? [
word stack-effect [
drop
] [
word swap "stack-effect" set-word-property
] ifte
] [
drop
] ifte ;
: documentation+ ( word str -- )
over "documentation" word-property [
swap "\n" swap cat3
] when*
"documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [
word swap documentation+
] [
drop
] ifte ;

28
library/syntax/unparser.factor
View File

@ -37,6 +37,34 @@ USE: stdio
USE: strings USE: strings
USE: words USE: words
: type-name ( n -- str )
[
[ 0 | "fixnum" ]
[ 1 | "word" ]
[ 2 | "cons" ]
[ 3 | "object" ]
[ 4 | "ratio" ]
[ 5 | "complex" ]
[ 6 | "f" ]
[ 7 | "t" ]
[ 8 | "array" ]
[ 9 | "bignum" ]
[ 10 | "float" ]
[ 11 | "vector" ]
[ 12 | "string" ]
[ 13 | "sbuf" ]
[ 14 | "port" ]
[ 15 | "dll" ]
[ 16 | "alien" ]
! These values are only used by the kernel for error
! reporting.
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc ;
GENERIC: unparse ( obj -- str ) GENERIC: unparse ( obj -- str )
M: object unparse ( obj -- str ) M: object unparse ( obj -- str )

2
library/test/benchmark/sort.factor
View File

@ -5,4 +5,4 @@ USE: math
USE: random USE: random
USE: test USE: test
[ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list num-sort drop ] unit-test [ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list [ > ] sort drop ] unit-test

2
library/test/inspector.factor
View File

@ -6,4 +6,4 @@ USE: words
"httpd" apropos. "httpd" apropos.
"car" usages. "car" usages.
global describe global describe
"vocabularies" get describe vocabularies get describe

6
library/test/lists/combinators.factor
View File

@ -17,10 +17,10 @@ USE: strings
[ [ 43 "a" [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test [ [ 43 "a" [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
[ "fdsfs" num-sort ] unit-test-fails [ "fdsfs" [ > ] sort ] unit-test-fails
[ [ ] ] [ [ ] num-sort ] unit-test [ [ ] ] [ [ ] [ > ] sort ] unit-test
[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ str-lexi> ] sort ] unit-test [ [ "2 + 2" ] ] [ [ "2 + 2" ] [ str-lexi> ] sort ] unit-test
[ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] num-sort ] unit-test [ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ > ] sort ] unit-test
[ f ] [ [ { } { } "Hello" ] all=? ] unit-test [ f ] [ [ { } { } "Hello" ] all=? ] unit-test
[ f ] [ [ { 2 } { } { } ] all=? ] unit-test [ f ] [ [ { 2 } { } { } ] all=? ] unit-test

4
library/test/lists/lists.factor
View File

@ -17,10 +17,6 @@ USE: strings
[ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test [ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test
[ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test [ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test
[ 1 ] [ -1 [ 1 2 ] nth ] unit-test
[ 1 ] [ 0 [ 1 2 ] nth ] unit-test
[ 2 ] [ 1 [ 1 2 ] nth ] unit-test
[ [ 3 ] ] [ [ 3 ] last* ] unit-test [ [ 3 ] ] [ [ 3 ] last* ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test
[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test [ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test

2
library/test/namespaces.factor
View File

@ -29,7 +29,7 @@ unit-test
[ t ] [ t ]
[ [
\ test-word \ test-word
global [ [ "vocabularies" "test" "test-word" ] object-path ] bind global [ [ vocabularies "test" "test-word" ] object-path ] bind
= =
] unit-test ] unit-test

3
library/test/test.factor
View File

@ -13,6 +13,7 @@ USE: prettyprint
USE: stdio USE: stdio
USE: strings USE: strings
USE: words USE: words
USE: vectors
USE: unparser USE: unparser
: assert ( t -- ) : assert ( t -- )
@ -62,7 +63,7 @@ USE: unparser
: all-tests ( -- ) : all-tests ( -- )
"Running Factor test suite..." print "Running Factor test suite..." print
"vocabularies" get [ f "scratchpad" set ] bind vocabularies get [ "scratchpad" off ] bind
[ [
"lists/cons" "lists/cons"
"lists/lists" "lists/lists"

2
library/test/words.factor
View File

@ -36,8 +36,6 @@ DEFER: plist-test
] unit-test ] unit-test
[ [
<namespace> "vocabularies" set
[ t ] [ \ car "car" [ "lists" ] search = ] unit-test [ t ] [ \ car "car" [ "lists" ] search = ] unit-test
"test-scope" "scratchpad" create drop "test-scope" "scratchpad" create drop

81
library/types.factor
View File

@ -1,81 +0,0 @@
! :folding=indent:collapseFolds=0:
! $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.
USE: kernel
USE: math
USE: generic
IN: vectors SYMBOL: vector
IN: math BUILTIN: fixnum 0
IN: words BUILTIN: word 1
IN: lists BUILTIN: cons 2
IN: math BUILTIN: ratio 4
IN: math BUILTIN: complex 5
IN: syntax BUILTIN: f 6 FORGET: f?
IN: syntax BUILTIN: t 7 FORGET: t?
IN: math BUILTIN: bignum 9
IN: math BUILTIN: float 10
IN: vectors BUILTIN: vector 11
IN: strings BUILTIN: string 12
IN: strings BUILTIN: sbuf 13
IN: io-internals BUILTIN: port 14
IN: alien BUILTIN: dll 15
IN: alien BUILTIN: alien 16
IN: kernel
: type-name ( n -- str )
[
[ 0 | "fixnum" ]
[ 1 | "word" ]
[ 2 | "cons" ]
[ 3 | "object" ]
[ 4 | "ratio" ]
[ 5 | "complex" ]
[ 6 | "f" ]
[ 7 | "t" ]
[ 8 | "array" ]
[ 9 | "bignum" ]
[ 10 | "float" ]
[ 11 | "vector" ]
[ 12 | "string" ]
[ 13 | "sbuf" ]
[ 14 | "port" ]
[ 15 | "dll" ]
[ 16 | "alien" ]
! These values are only used by the kernel for error
! reporting.
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc ;
: num-types ( -- n )
#! One more than the maximum value from type primitive.
17 ;

12
library/vectors.factor
View File

@ -26,10 +26,13 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: vectors IN: vectors
USE: generic
USE: kernel USE: kernel
USE: lists USE: lists
USE: math USE: math
BUILTIN: vector 11
: empty-vector ( len -- vec ) : empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike #! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain #! <vector>, which gives an empty vector with a certain
@ -105,6 +108,15 @@ USE: math
#! Shallow copy of a vector. #! Shallow copy of a vector.
[ ] vector-map ; [ ] vector-map ;
: list>vector ( list -- vector )
dup length <vector> swap [ over vector-push ] each ;
: stack>list ( vector -- list )
[ ] swap [ swons ] vector-each ;
: vector>list ( vector -- list )
stack>list reverse ;
: vector-length= ( vec vec -- ? ) : vector-length= ( vec vec -- ? )
vector-length swap vector-length number= ; vector-length swap vector-length number= ;

78
library/vocabularies.factor
View File

@ -30,6 +30,31 @@ USE: hashtables
USE: kernel USE: kernel
USE: lists USE: lists
USE: namespaces USE: namespaces
USE: strings
: word ( -- word ) global [ "last-word" get ] bind ;
: set-word ( word -- ) global [ "last-word" set ] bind ;
: vocabs ( -- list )
#! Push a list of vocabularies.
vocabularies get hash-keys [ str-lexi> ] sort ;
: vocab ( name -- vocab )
#! Get a vocabulary.
vocabularies get hash ;
: word-sort ( list -- list )
#! Sort a list of words by name.
[ swap word-name swap word-name str-lexi> ] sort ;
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
vocab hash-values [ ] subset word-sort ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
vocabs [ words [ swap dup >r call r> ] each ] each drop ;
: (search) ( name vocab -- word ) : (search) ( name vocab -- word )
vocab dup [ hash ] [ 2drop f ] ifte ; vocab dup [ hash ] [ 2drop f ] ifte ;
@ -55,12 +80,10 @@ USE: namespaces
: reveal ( word -- ) : reveal ( word -- )
#! Add a new word to its vocabulary. #! Add a new word to its vocabulary.
global [ vocabularies get [
"vocabularies" get [ dup word-vocabulary
dup word-vocabulary over word-name
over word-name 2list set-object-path
2list set-object-path
] bind
] bind ; ] bind ;
: create ( name vocab -- word ) : create ( name vocab -- word )
@ -72,3 +95,46 @@ USE: namespaces
: forget ( word -- ) : forget ( word -- )
#! Remove a word definition. #! Remove a word definition.
dup word-vocabulary vocab [ word-name off ] bind ; dup word-vocabulary vocab [ word-name off ] bind ;
: init-search-path ( -- )
! For files
"scratchpad" "file-in" set
[ "builtins" "syntax" "scratchpad" ] "file-use" set
! For interactive
"scratchpad" "in" set
[
"user"
"arithmetic"
"builtins"
"compiler"
"debugger"
"errors"
"files"
"hashtables"
"inference"
"inferior"
"interpreter"
"inspector"
"jedit"
"kernel"
"listener"
"lists"
"math"
"namespaces"
"parser"
"prettyprint"
"processes"
"profiler"
"stack"
"streams"
"stdio"
"strings"
"syntax"
"test"
"threads"
"unparser"
"vectors"
"vocabularies"
"words"
"scratchpad"
] "use" set ;

81
library/words.factor
View File

@ -34,6 +34,10 @@ USE: math
USE: namespaces USE: namespaces
USE: strings USE: strings
BUILTIN: word 1
SYMBOL: vocabularies
: word-property ( word pname -- pvalue ) : word-property ( word pname -- pvalue )
swap word-plist assoc ; swap word-plist assoc ;
@ -47,19 +51,11 @@ PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ; PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ;
PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
: word ( -- word ) global [ "last-word" get ] bind ; : define ( word primitive parameter -- )
: set-word ( word -- ) global [ "last-word" set ] bind ;
: (define) ( word primitive parameter -- )
#! Define a word in the current Factor instance.
pick set-word-parameter pick set-word-parameter
over set-word-primitive over set-word-primitive
f "parsing" set-word-property ; f "parsing" set-word-property ;
: define ( word primitive parameter -- )
#! The define-hook is set by the image bootstrapping code.
"define-hook" get [ call ] [ (define) ] ifte* ;
: define-compound ( word def -- ) 1 swap define ; : define-compound ( word def -- ) 1 swap define ;
: define-symbol ( word -- ) 2 over define ; : define-symbol ( word -- ) 2 over define ;
@ -68,66 +64,7 @@ PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
: stack-effect ( word -- str ) "stack-effect" word-property ; : stack-effect ( word -- str ) "stack-effect" word-property ;
: documentation ( word -- str ) "documentation" word-property ; : documentation ( word -- str ) "documentation" word-property ;
: vocabs ( -- list ) : word-clone ( word -- word )
#! Push a list of vocabularies. dup word-primitive
global [ "vocabularies" get hash-keys str-sort ] bind ; over word-parameter
rot word-plist <word> ;
: vocab ( name -- vocab )
#! Get a vocabulary.
global [ "vocabularies" get hash ] bind ;
: word-sort ( list -- list )
#! Sort a list of words by name.
[ swap word-name swap word-name str-lexi> ] sort ;
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
vocab hash-values [ ] subset word-sort ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
vocabs [ words [ swap dup >r call r> ] each ] each drop ;
: init-search-path ( -- )
! For files
"scratchpad" "file-in" set
[ "builtins" "syntax" "scratchpad" ] "file-use" set
! For interactive
"scratchpad" "in" set
[
"user"
"arithmetic"
"builtins"
"compiler"
"debugger"
"errors"
"files"
"hashtables"
"inference"
"inferior"
"interpreter"
"inspector"
"jedit"
"kernel"
"listener"
"lists"
"math"
"namespaces"
"parser"
"prettyprint"
"processes"
"profiler"
"stack"
"streams"
"stdio"
"strings"
"syntax"
"test"
"threads"
"unparser"
"vectors"
"vocabularies"
"words"
"scratchpad"
] "use" set ;

6
native/types.h
View File

@ -51,6 +51,8 @@ INLINE CELL tag_header(CELL cell)
return RETAG(cell << TAG_BITS,HEADER_TYPE); return RETAG(cell << TAG_BITS,HEADER_TYPE);
} }
#define HEADER_DEBUG
INLINE CELL untag_header(CELL cell) INLINE CELL untag_header(CELL cell)
{ {
CELL type = cell >> TAG_BITS; CELL type = cell >> TAG_BITS;
@ -77,6 +79,10 @@ INLINE void type_check(CELL type, CELL tagged)
{ {
if(type < HEADER_TYPE) if(type < HEADER_TYPE)
{ {
#ifdef HEADER_DEBUG
if(type == WORD_TYPE && object_type(tagged) != WORD_TYPE)
critical_error("word header check",tagged);
#endif
if(TAG(tagged) == type) if(TAG(tagged) == type)
return; return;
} }