USE: test
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 )
#! Returns a random element from the given list.
dup >r length pred 0 swap random-int r> nth ;
"random-pairs" get
check-random-subset
] 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
getExternalInstance().eval(cmd);
} //}}}
- //{{{ factorWord() method
+ //{{{ lookupWord() 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 FactorWord lookupWord(View view, String word)
{
- return FactorReader.unparseObject(word.name)
- + " [ " + FactorReader.unparseObject(word.vocabulary)
- + " ] search";
+ SideKickParsedData data = SideKickParsedData.getParsedData(view);
+ if(data instanceof FactorParsedData)
+ {
+ FactorParsedData fdata = (FactorParsedData)data;
+ return getExternalInstance().searchVocabulary(fdata.use,word);
+ }
+ else
+ return null;
} //}}}
//{{{ 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(View view)
+ public static String factorWord(View view, String word)
{
- JEditTextArea textArea = view.getTextArea();
SideKickParsedData data = SideKickParsedData
.getParsedData(view);
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)
else
return null;
} //}}}
+
+ //{{{ factorWord() method
+ /**
+ * Build a Factor expression for pushing the selected word on the stack
+ */
+ public static String factorWord(View view)
+ {
+ JEditTextArea textArea = view.getTextArea();
+ String word = FactorPlugin.getWordAtCaret(textArea);
+ if(word == 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
/**
USE: stdio\r
\r
"Cold boot in progress..." print\r
+\r
[\r
"/version.factor"\r
"/library/stack.factor"\r
"/library/generic/builtin.factor"\r
"/library/generic/predicate.factor"\r
"/library/generic/traits.factor"\r
- "/library/types.factor"\r
"/library/math/math.factor"\r
"/library/cons.factor"\r
"/library/combinators.factor"\r
"/library/compiler/xt.factor"\r
"/library/compiler/optimizer.factor"\r
"/library/compiler/linearizer.factor"\r
+ "/library/compiler/simplifier.factor"\r
"/library/compiler/generator.factor"\r
"/library/compiler/compiler.factor"\r
"/library/compiler/alien-types.factor"\r
"/library/sdl/hsv.factor"\r
\r
"/library/bootstrap/image.factor"\r
- "/library/bootstrap/cross-compiler.factor"\r
\r
"/library/httpd/url-encoding.factor"\r
"/library/httpd/html-tags.factor"\r
USE: stdio
USE: kernel
USE: vectors
+USE: words
+USE: hashtables
-primitives,
-[
- "/version.factor"
- "/library/stack.factor"
- "/library/kernel.factor"
- "/library/generic/generic.factor"
- "/library/generic/object.factor"
- "/library/generic/builtin.factor"
- "/library/generic/predicate.factor"
- "/library/generic/traits.factor"
- "/library/types.factor"
- "/library/combinators.factor"
- "/library/math/math.factor"
- "/library/cons.factor"
- "/library/logic.factor"
- "/library/vectors.factor"
- "/library/lists.factor"
- "/library/assoc.factor"
- "/library/math/arithmetic.factor"
- "/library/math/math-combinators.factor"
- "/library/strings.factor"
- "/library/hashtables.factor"
- "/library/namespaces.factor"
- "/library/list-namespaces.factor"
- "/library/sbuf.factor"
- "/library/continuations.factor"
- "/library/errors.factor"
- "/library/threads.factor"
- "/library/io/stream.factor"
- "/library/io/io-internals.factor"
- "/library/io/stream-impl.factor"
- "/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
+"/library/bootstrap/primitives.factor" run-resource
+"/version.factor" run-resource
+"/library/stack.factor" run-resource
+"/library/combinators.factor" run-resource
+"/library/kernel.factor" run-resource
+"/library/logic.factor" run-resource
+"/library/cons.factor" run-resource
+"/library/assoc.factor" run-resource
+"/library/math/generic.factor" run-resource
+"/library/words.factor" run-resource
+"/library/math/arithmetic.factor" run-resource
+"/library/math/math-combinators.factor" run-resource
+"/library/math/math.factor" run-resource
+"/library/lists.factor" run-resource
+"/library/vectors.factor" run-resource
+"/library/strings.factor" run-resource
+"/library/hashtables.factor" run-resource
+"/library/namespaces.factor" run-resource
+"/library/list-namespaces.factor" run-resource
+"/library/sbuf.factor" run-resource
+"/library/errors.factor" run-resource
+"/library/continuations.factor" run-resource
+"/library/threads.factor" run-resource
+"/library/io/stream.factor" run-resource
+"/library/io/stdio.factor" run-resource
+"/library/io/io-internals.factor" run-resource
+"/library/io/stream-impl.factor" run-resource
+"/library/vocabularies.factor" run-resource
+"/library/syntax/parse-numbers.factor" run-resource
+"/library/syntax/parser.factor" run-resource
+"/library/syntax/parse-stream.factor" run-resource
-IN: init
-DEFER: boot
+! A bootstrapping trick. See doc/bootstrap.txt.
+vocabularies get [
+ "generic" off
+] bind
-[
- boot
- "Good morning!" print
- flush
- "/library/bootstrap/boot-stage2.factor" run-resource
-] boot-quot set
+"/library/generic/generic.factor" run-resource
+"/library/generic/object.factor" run-resource
+"/library/generic/builtin.factor" run-resource
+"/library/generic/predicate.factor" run-resource
+"/library/generic/traits.factor" run-resource
+
+"/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
+++ /dev/null
-! :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 ;
USE: vectors
USE: unparser
USE: words
-
-USE: stack
-USE: combinators
-USE: logic
+USE: parser
! The image being constructed; a vector of word-size integers
SYMBOL: image
( Words )
-: word, ( word -- pointer )
- word-tag here-as >r word-tag >header emit
- hashcode emit ( hashcode )
- 0 emit r> ;
+: make-plist ( word -- plist )
+ [
+ dup word-name "name" swons ,
+ 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 )
dup pooled-object dup [
nip
] [
- drop
- [
- "Not in image: " ,
- dup word-vocabulary ,
- " " ,
- word-name ,
- ] make-string throw
+ drop "Not in image: " word-error
] ifte ;
: fixup-words ( -- )
] vector-map image set ;
M: word ' ( word -- pointer )
- dup pooled-object dup [ nip ] [ drop ] ifte ;
+ transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
( Conses )
drop dup emit-string dup >r pool-object r>
] 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 )
: emit-array ( list -- pointer )
( End of the image )
-: vocabularies, ( -- )
- #! Produces code with stack effect ( -- vocabularies ).
- #! This code sets up vocabulary hash tables.
- \ <namespace> ,
+: vocabularies, ( vocabularies -- )
[
- "vocabularies" get [
- uncons hash>alist , \ alist>hash , , \ set ,
- ] hash-each
- ] make-list ,
- \ extend , ;
+ cdr dup vector? [
+ [
+ cdr dup word? [ word, ] [ drop ] ifte
+ ] hash-each
+ ] [
+ drop
+ ] ifte
+ ] hash-each ;
: global, ( -- )
- #! Produces code with stack effect ( vocabularies -- ).
- <namespace> ' global-offset fixup
- "vocabularies" ,
- \ global ,
- \ set-hash , ;
-
-: hash-quot ( -- quot )
- #! Generate a quotation to generate vocabulary and global
- #! namespace hashtables.
- [ vocabularies, global, ] make-list ;
+ vocabularies get
+ dup vocabularies,
+ <namespace> [ vocabularies set ] extend '
+ global-offset fixup ;
: boot, ( quot -- )
- boot-quot get append ' boot-quot-offset fixup ;
+ boot-quot get ' boot-quot-offset fixup ;
: end ( -- )
- hash-quot
boot,
+ global,
fixup-words
here base - heap-size-offset fixup ;
[
300000 <vector> image set
521 <hashtable> "objects" set
- namespace-buckets <hashtable> "vocabularies" set
! Note that this is a vector that we can side-effect,
! since ; ends up using this variable from nested
! parser namespaces.
[ begin call end ] with-minimal-image ;
: 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 ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
-USE: compiler
-USE: errors
USE: kernel
USE: namespaces
USE: parser
USE: streams
USE: threads
USE: words
-USE: vectors
: boot ( -- )
#! Initialize an interpreter with the basic services.
init-threads
init-stdio
"HOME" os-env [ "." ] unless* "~" set
- "/" "/" set
init-search-path ;
+
+[
+ boot
+ "Good morning!" print
+ flush
+ "/library/bootstrap/boot-stage2.factor" run-resource
+]
--- /dev/null
+! :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
: run-user-init ( -- )
#! Run user init file if it exists
"user-init" get [
- [ "~" get , "/" get , ".factor-" , "rc" , ] make-string
+ [ "~" get , "/" , ".factor-" , "rc" , ] make-string
?run-file
] when ;
#! Apply code to input.
swap dup >r call r> swap ; inline
+IN: lists DEFER: uncons IN: kernel
: cond ( x list -- )
#! The list is of this form:
#!
IN: alien
USE: compiler
USE: errors
+USE: generic
USE: inference
USE: interpreter
USE: kernel
USE: parser
USE: words
+BUILTIN: dll 15
+BUILTIN: alien 16
+
: library ( name -- handle )
"libraries" get [
dup get dup dll? [
gensym dup t "label" set-word-property ;
: label? ( obj -- ? )
- dup word ? [ "label" word-property ] [ drop f ] ifte ;
+ dup word? [ "label" word-property ] [ drop f ] ifte ;
: label, ( label -- )
#label swons , ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lists
+USE: generic
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 ] )
#! Push a new cons cell. If the cdr is f or a proper list,
#! has the effect of prepending the car to the cdr.
: 2cdr ( cons cons -- car car )
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
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: kernel
+DEFER: callcc1
+
IN: errors
USE: kernel
USE: lists
! - metaclass: a metaclass is a symbol with a handful of word
! properties: "define-method" "builtin-types"
+: undefined-method
+ "No applicable method." throw ;
+
: metaclass ( class -- metaclass )
"metaclass" word-property ;
: init-traits-map ( word -- )
<namespace> "traits-map" set-word-property ;
-: undefined-method
- "No applicable method." throw ;
-
: traits-dispatch ( selector traits -- traits quot )
#! Look up the method with the traits object on the stack.
#! Returns the traits to call the method on; either the
: alist>hash ( alist -- hash )
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 ;
: directory ( dir -- list )
#! List a directory.
- (directory) str-sort ;
+ (directory) [ str-lexi> ] sort ;
: file-length ( file -- length )
stat dup [ cdr cdr car ] when ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: io-internals
+USE: generic
USE: kernel
USE: namespaces
USE: strings
USE: threads
+BUILTIN: port 14
+
: stdin 0 getenv ;
: stdout 1 getenv ;
: fread1 ( stream -- string )
1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ;
-: fprint ( string stream -- )
- tuck fwrite "\n" over fwrite fauto-flush ;
-
: fwrite ( string stream -- )
f swap fwrite-attr ;
+: fprint ( string stream -- )
+ tuck fwrite "\n" over fwrite fauto-flush ;
+
TRAITS: string-output-stream
M: string-output-stream fwrite-attr ( string style stream -- )
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: syntax
+USE: generic
+BUILTIN: f 6 FORGET: f?
+BUILTIN: t 7 FORGET: t?
+
IN: vectors
DEFER: vector=
DEFER: vector-hashcode
+IN: lists
+DEFER: cons=
+DEFER: cons-hashcode
+
IN: kernel
USE: lists
USE: math
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
+
+: num-types ( -- n )
+ #! One more than the maximum value from type primitive.
+ 17 ;
#! Test if a list contains an element.
[ 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 )
rot [ swapd cons ] [ >r cons r> ] ifte ;
drop
] ifte ; inline
-: num-sort ( list -- sorted )
- #! Sorts the list into ascending numerical order.
- [ > ] sort ;
-
! Redefined below
DEFER: tree-contains?
#! list.
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 )
[ ] swap [ swons ] each ;
#! ( X -- Y ) to each element into a new list.
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 all occurrences of the object from the list.
[ dupd = not ] subset nip ;
uncons prune 2dup contains? [ nip ] [ cons ] ifte
] 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 -- ? )
#! Check if all elements of a list are equal.
dup [ uncons [ over = ] all? nip ] [ drop t ] ifte ;
: cons-hashcode ( cons -- hash )
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 )
#! Execute the quotation n times, passing the loop counter
#! the quotation as it ranges from 0..n-1. Collect results
USE: vectors
USE: words
+BUILTIN: fixnum 0
+BUILTIN: ratio 4
+BUILTIN: complex 5
+BUILTIN: bignum 9
+BUILTIN: float 10
+
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 ) abs swap abs 2dup < [ swap ] when (gcd) ;
: set-global ( g -- ) 4 setenv ;
: init-namespaces ( -- )
- global >n global "global" set ;
+ global >n ;
: namespace-buckets 23 ;
USE: lists
USE: math
USE: namespaces
+USE: vectors
: 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> ;
: q ( v s f -- q ) * neg succ * ;
: t_ ( v s f -- t_ ) neg succ * neg succ * ;
-: mod-cond ( p list -- )
- #! Call p mod q'th entry of the list of quotations, where
- #! q is the length of the list. The value q remains on the
+: mod-cond ( p vector -- )
+ #! Call p mod q'th entry of the vector of quotations, where
+ #! q is the length of the vector. The value q remains on the
#! stack.
- [ dupd length mod ] keep nth call ;
+ [ dupd length mod ] keep vector-nth call ;
: hsv>rgb ( h s v -- r g b )
- pick 6 * >fixnum [
+ pick 6 * >fixnum {
[ f_ t_ p swap ( v p t ) ]
[ f_ q p -rot ( q v p ) ]
[ f_ t_ p swapd ( p v t ) ]
[ f_ q p rot ( p q v ) ]
[ f_ t_ p swap rot ( t p v ) ]
[ f_ q p ( v p q ) ]
- ] mod-cond ;
+ } mod-cond ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: strings
+USE: generic
USE: kernel
USE: lists
USE: math
+BUILTIN: string 12
+BUILTIN: sbuf 13
+
: f-or-"" ( obj -- ? )
dup not swap "" = or ;
-rot 2dup >r >r >r str-nth r> call r> r>
] 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? ;
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ;
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ;
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: parser
+! Bootstrapping trick; see doc/bootstrap.txt.
+IN: !syntax
+USE: syntax
USE: errors
USE: hashtables
USE: lists
USE: math
USE: namespaces
+USE: parser
USE: strings
USE: words
USE: vectors
USE: unparser
-! Colon defs
-: 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 ;
-
-! \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
+: parsing ( -- )
+ #! Mark the most recently defined word to execute at parse
+ #! time, rather than run time. The word can use 'scan' to
+ #! read ahead in the input stream.
+ word t "parsing" set-word-property ; parsing
: inline ( -- )
#! Mark the last word to be inlined.
] ifte
] [
r> drop nip str-length
- ] ifte ;
+ ] ifte ; inline
: skip-blank ( n line -- n )
[ blank? not ] skip ;
: next-word-ch ( -- 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 ;
+
+! \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 ;
-: parsing ( -- )
- #! Mark the most recently defined word to execute at parse
- #! time, rather than run time. The word can use 'scan' to
- #! read ahead in the input stream.
- word t "parsing" set-word-property ;
+: documentation+ ( word str -- )
+ over "documentation" word-property [
+ swap "\n" swap cat3
+ ] when*
+ "documentation" set-word-property ;
-! Once this file has loaded, we can use 'parsing' normally.
-! This hack is needed because in Java Factor, 'parsing' is
-! not parsing, but in CFactor, it is.
-\ parsing t "parsing" set-word-property
+: parsed-documentation ( parsed str -- parsed )
+ over doc-comment-here? [
+ word swap documentation+
+ ] [
+ drop
+ ] ifte ;
USE: strings
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 )
M: object unparse ( obj -- str )
USE: random
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
"httpd" apropos.
"car" usages.
global describe
-"vocabularies" get describe
+vocabularies get describe
[ [ 43 "a" [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
-[ "fdsfs" num-sort ] unit-test-fails
-[ [ ] ] [ [ ] num-sort ] unit-test
+[ "fdsfs" [ > ] sort ] unit-test-fails
+[ [ ] ] [ [ ] [ > ] 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 ] [ [ { 2 } { } { } ] all=? ] unit-test
[ t ] [ 1 [ 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 ] ] [ [ 1 2 3 ] last* ] unit-test
[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test
[ t ]
[
\ test-word
- global [ [ "vocabularies" "test" "test-word" ] object-path ] bind
+ global [ [ vocabularies "test" "test-word" ] object-path ] bind
=
] unit-test
USE: stdio
USE: strings
USE: words
+USE: vectors
USE: unparser
: assert ( t -- )
: all-tests ( -- )
"Running Factor test suite..." print
- "vocabularies" get [ f "scratchpad" set ] bind
+ vocabularies get [ "scratchpad" off ] bind
[
"lists/cons"
"lists/lists"
] unit-test
[
- <namespace> "vocabularies" set
-
[ t ] [ \ car "car" [ "lists" ] search = ] unit-test
"test-scope" "scratchpad" create drop
+++ /dev/null
-! :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 ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: vectors
+USE: generic
USE: kernel
USE: lists
USE: math
+BUILTIN: vector 11
+
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain
#! Shallow copy of a vector.
[ ] 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 swap vector-length number= ;
USE: kernel
USE: lists
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 )
vocab dup [ hash ] [ 2drop f ] ifte ;
: reveal ( word -- )
#! Add a new word to its vocabulary.
- global [
- "vocabularies" get [
- dup word-vocabulary
- over word-name
- 2list set-object-path
- ] bind
+ vocabularies get [
+ dup word-vocabulary
+ over word-name
+ 2list set-object-path
] bind ;
: create ( name vocab -- word )
: forget ( word -- )
#! Remove a word definition.
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 ;
USE: namespaces
USE: strings
+BUILTIN: word 1
+
+SYMBOL: vocabularies
+
: word-property ( word pname -- pvalue )
swap word-plist assoc ;
PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ;
PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
-: word ( -- word ) global [ "last-word" get ] bind ;
-: set-word ( word -- ) global [ "last-word" set ] bind ;
-
-: (define) ( word primitive parameter -- )
- #! Define a word in the current Factor instance.
+: define ( word primitive parameter -- )
pick set-word-parameter
over set-word-primitive
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-symbol ( word -- ) 2 over define ;
: stack-effect ( word -- str ) "stack-effect" word-property ;
: documentation ( word -- str ) "documentation" word-property ;
-: vocabs ( -- list )
- #! Push a list of vocabularies.
- global [ "vocabularies" get hash-keys str-sort ] bind ;
-
-: 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 ;
+: word-clone ( word -- word )
+ dup word-primitive
+ over word-parameter
+ rot word-plist <word> ;
return RETAG(cell << TAG_BITS,HEADER_TYPE);
}
+#define HEADER_DEBUG
+
INLINE CELL untag_header(CELL cell)
{
CELL type = cell >> TAG_BITS;
{
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)
return;
}
projects / factor.git / commitdiff