+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: ansi
-USE: combinators
-USE: lists
-USE: kernel
-USE: format
-USE: namespaces
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-
-! Some words for outputting ANSI colors.
-
-: black 0 ; inline
-: red 1 ; inline
-: green 2 ; inline
-: yellow 3 ; inline
-: blue 4 ; inline
-: magenta 5 ; inline
-: cyan 6 ; inline
-: white 7 ; inline
-
-: clear ( -- code )
- #! Clear screen
- "\e[2J\e[H" ; inline
-
-: reset ( -- code )
- #! Reset ANSI color codes.
- "\e[0m" ; inline
-
-: bold ( -- code )
- #! Switch on boldface.
- "\e[1m" ; inline
-
-: fg ( color -- code )
- #! Set foreground color.
- "\e[3" swap "m" cat3 ; inline
-
-: bg ( color -- code )
- #! Set foreground color.
- "\e[4" swap "m" cat3 ; inline
-
-: ansi-attrs ( style -- )
- "bold" over assoc [ bold , ] when
- "ansi-fg" over assoc [ fg , ] when*
- "ansi-bg" over assoc [ bg , ] when*
- drop ;
-
-: ansi-attr-string ( string style -- string )
- [ ansi-attrs , reset , ] make-string ;
-
-: <ansi-stream> ( stream -- stream )
- #! Wraps the given stream in an ANSI stream. ANSI streams
- #! support the following character attributes:
- #! bold - if not f, text is boldface.
- #! ansi-fg - foreground color
- #! ansi-bg - background color
- <extend-stream> [
- ( string style -- )
- [ ansi-attr-string write ] "fwrite-attr" set
- ] extend ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: init
+USE: combinators
+USE: kernel
+USE: lists
+USE: parser
+USE: stack
+USE: stdio
+
+"Cold boot in progress..." print
+[
+ "/library/kernel.factor"
+ "/library/stack.factor"
+ "/library/types.factor"
+ "/library/math/math.factor"
+ "/library/cons.factor"
+ "/library/combinators.factor"
+ "/library/logic.factor"
+ "/library/vector-combinators.factor"
+ "/library/lists.factor"
+ "/library/assoc.factor"
+ "/library/math/arithmetic.factor"
+ "/library/math/math-combinators.factor"
+ "/library/vectors.factor"
+ "/library/strings.factor"
+ "/library/hashtables.factor"
+ "/library/namespaces.factor"
+ "/library/math/namespace-math.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/io/extend-stream.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"
+
+ "/library/format.factor"
+ "/library/syntax/unparser.factor"
+ "/library/io/presentation.factor"
+ "/library/io/vocabulary-style.factor"
+ "/library/syntax/prettyprint.factor"
+ "/library/syntax/see.factor"
+ "/library/tools/debugger.factor"
+
+ "/library/math/constants.factor"
+ "/library/math/pow.factor"
+ "/library/math/trig-hyp.factor"
+ "/library/math/arc-trig-hyp.factor"
+
+ "/library/in-thread.factor"
+ "/library/io/network.factor"
+ "/library/io/logging.factor"
+ "/library/random.factor"
+ "/library/io/stdio-binary.factor"
+ "/library/io/files.factor"
+ "/library/eval-catch.factor"
+ "/library/tools/listener.factor"
+ "/library/tools/inspector.factor"
+ "/library/tools/word-tools.factor"
+ "/library/test/test.factor"
+ "/library/io/ansi.factor"
+ "/library/tools/telnetd.factor"
+ "/library/tools/jedit-wire.factor"
+ "/library/tools/profiler.factor"
+ "/library/tools/heap-stats.factor"
+ "/library/gensym.factor"
+ "/library/tools/interpreter.factor"
+ "/library/tools/inference.factor"
+
+ "/library/bootstrap/image.factor"
+ "/library/bootstrap/cross-compiler.factor"
+
+ "/library/httpd/url-encoding.factor"
+ "/library/httpd/html-tags.factor"
+ "/library/httpd/html.factor"
+ "/library/httpd/http-common.factor"
+ "/library/httpd/responder.factor"
+ "/library/httpd/httpd.factor"
+ "/library/httpd/file-responder.factor"
+ "/library/httpd/inspect-responder.factor"
+ "/library/httpd/test-responder.factor"
+ "/library/httpd/quit-responder.factor"
+ "/library/httpd/resource-responder.factor"
+ "/library/httpd/default-responders.factor"
+
+ "/library/tools/jedit.factor"
+
+ "/library/primitives.factor"
+
+ "/library/cli.factor"
+] [
+ dup print
+ run-resource
+] each
+
+cpu "x86" = [
+ [
+ "/library/compiler/assembler.factor"
+ "/library/compiler/assembly-x86.factor"
+ "/library/compiler/compiler-macros.factor"
+ "/library/compiler/compiler.factor"
+ "/library/compiler/ifte.factor"
+ "/library/compiler/generic.factor"
+ "/library/compiler/stack.factor"
+ "/library/compiler/interpret-only.factor"
+ "/library/compiler/alien-types.factor"
+ "/library/compiler/alien-macros.factor"
+ "/library/compiler/alien.factor"
+
+ "/library/sdl/sdl.factor"
+ "/library/sdl/sdl-video.factor"
+ "/library/sdl/sdl-event.factor"
+ "/library/sdl/sdl-gfx.factor"
+ "/library/sdl/sdl-keysym.factor"
+ "/library/sdl/sdl-utils.factor"
+ "/library/sdl/hsv.factor"
+ ] [
+ dup print
+ run-resource
+ ] each
+] [
+ "/library/compiler/dummy-compiler.factor" dup print run-resource
+] ifte
+
+"/library/bootstrap/init-stage2.factor" dup print 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.
+
+USE: lists
+USE: image
+USE: parser
+
+primitives,
+[
+ "/library/kernel.factor"
+ "/library/stack.factor"
+ "/library/types.factor"
+ "/library/math/math.factor"
+ "/library/cons.factor"
+ "/library/combinators.factor"
+ "/library/logic.factor"
+ "/library/vector-combinators.factor"
+ "/library/lists.factor"
+ "/library/assoc.factor"
+ "/library/math/arithmetic.factor"
+ "/library/math/math-combinators.factor"
+ "/library/vectors.factor"
+ "/library/strings.factor"
+ "/library/hashtables.factor"
+ "/library/namespaces.factor"
+ "/library/math/namespace-math.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/io/extend-stream.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
+
+version,
+
+IN: init
+DEFER: boot
+
+[
+ boot
+ "/library/bootstrap/boot-stage2.factor" run-resource
+] (set-boot)
--- /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: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: parser
+USE: real-math
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+USE: vectors
+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
+
+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: arithmetic-type
+DEFER: >fraction
+DEFER: fraction>
+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>=
+
+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
+ nip
+ tuck
+ rot
+ >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
+ ] [
+ swap succ tuck primitive,
+ ] each drop ;
+
+: version, ( -- )
+ "version" [ "kernel" ] search version unit compound, ;
+
+: 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 ;
+
+: cross-compile-resource ( resource -- )
+ [
+ ! Change behavior of ;
+ [ compound, ] ";-hook" set
+ run-resource
+ ] with-scope ;
--- /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.
+
+! This library allows one to generate a new set of bootstrap
+! images (boot.image.{le32,le64,be32,be64}.
+!
+! It does this by parsing the set of source files needed to
+! generate the minimal image, and writing the cons cells, words,
+! strings etc to the image file in the CFactor object memory
+! format.
+!
+! What is a bootstrap image? It basically contains enough code
+! to parse a source file. See platform/native/boot.factor --
+! It initializes the core interpreter services, and proceeds to
+! run platform/native/boot-stage2.factor.
+
+IN: namespaces
+
+( Java Factor doesn't have this )
+: namespace-buckets 23 ;
+
+IN: image
+USE: combinators
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: random
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+USE: test
+USE: vectors
+USE: unparser
+USE: words
+
+: image "image" get ;
+: emit ( cell -- ) image vector-push ;
+
+: fixup ( value offset -- ) image set-vector-nth ;
+
+( Object memory )
+
+: image-magic HEX: 0f0e0d0c ;
+: image-version 0 ;
+
+: cell "64-bits" get 8 4 ? ;
+: char "64-bits" get 4 2 ? ;
+
+: tag-mask BIN: 111 ;
+: tag-bits 3 ;
+
+: untag ( cell tag -- ) tag-mask bitnot bitand ;
+: tag ( cell -- tag ) tag-mask bitand ;
+
+: fixnum-tag BIN: 000 ;
+: word-tag BIN: 001 ;
+: cons-tag BIN: 010 ;
+: object-tag BIN: 011 ;
+: ratio-tag BIN: 100 ;
+: complex-tag BIN: 101 ;
+: header-tag BIN: 110 ;
+: gc-fwd-ptr BIN: 111 ; ( we don't output these )
+
+: f-type 6 ;
+: t-type 7 ;
+: array-type 8 ;
+: bignum-type 9 ;
+: float-type 10 ;
+: vector-type 11 ;
+: string-type 12 ;
+
+: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
+: >header ( id -- tagged ) header-tag immediate ;
+
+( Image header )
+
+: base
+ #! We relocate the image to after the header, and leaving
+ #! two empty cells. This lets us differentiate an F pointer
+ #! (0/tag 3) from a pointer to the first object in the
+ #! image.
+ 2 cell * ;
+
+: header ( -- )
+ image-magic emit
+ image-version emit
+ ( relocation base at end of header ) base emit
+ ( bootstrap quotation set later ) 0 emit
+ ( global namespace set later ) 0 emit
+ ( size of heap set later ) 0 emit ;
+
+: boot-quot-offset 3 ;
+: global-offset 4 ;
+: heap-size-offset 5 ;
+: header-size 6 ;
+
+( Allocator )
+
+: here ( -- size )
+ image vector-length header-size - cell * base + ;
+
+: here-as ( tag -- pointer )
+ here swap bitor ;
+
+: pad ( -- )
+ here 8 mod 4 = [ 0 emit ] when ;
+
+( Remember what objects we've compiled )
+
+: pooled-object ( object -- pointer )
+ "objects" get hash ;
+
+: pool-object ( object pointer -- )
+ swap "objects" get set-hash ;
+
+( Fixnums )
+
+: 'fixnum ( n -- tagged ) fixnum-tag immediate ;
+
+( Bignums )
+
+: 'bignum ( bignum -- tagged )
+ object-tag here-as >r
+ bignum-type >header emit
+ dup 0 = 1 2 ? emit ( capacity )
+ [
+ [ 0 = ] [ emit pad ]
+ [ 0 < ] [ 1 emit neg emit ]
+ [ 0 > ] [ 0 emit emit ]
+ ] cond r> ;
+
+( Special objects )
+
+! Padded with fixnums for 8-byte alignment
+
+: t,
+ object-tag here-as "t" set
+ t-type >header emit
+ 0 'fixnum emit ;
+
+: 0, 0 'bignum drop ;
+: 1, 1 'bignum drop ;
+: -1, -1 'bignum drop ;
+
+( Beginning of the image )
+! The image proper begins with the header, then T,
+! and the bignums 0, 1, and -1.
+
+: begin ( -- ) header t, 0, 1, -1, ;
+
+( Words )
+
+: word, ( -- pointer )
+ word-tag here-as word-tag >header emit
+ 0 HEX: fffffff random-int emit ( hashcode )
+ 0 emit ;
+
+! This is to handle mutually recursive words
+
+: fixup-word ( word -- offset )
+ dup pooled-object dup [
+ nip
+ ] [
+ drop "Not in image: " swap word-name cat2 throw
+ ] ifte ;
+
+: fixup-words ( -- )
+ "image" get [
+ dup word? [ fixup-word ] when
+ ] vector-map "image" set ;
+
+: 'word ( word -- pointer )
+ dup pooled-object dup [ nip ] [ drop ] ifte ;
+
+( Conses )
+
+DEFER: '
+
+: cons, ( -- pointer ) cons-tag here-as ;
+: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
+
+( Ratios -- almost the same as a cons )
+
+: ratio, ( -- pointer ) ratio-tag here-as ;
+: 'ratio ( a/b -- tagged )
+ dup denominator ' swap numerator ' ratio, -rot emit emit ;
+
+( Complex -- almost the same as ratio )
+
+: complex, ( -- pointer ) complex-tag here-as ;
+: 'complex ( #{ a b } -- tagged )
+ dup imaginary ' swap real ' complex, -rot emit emit ;
+
+( Strings )
+
+: align-string ( n str -- )
+ tuck str-length - CHAR: \0 fill cat2 ;
+
+: emit-string ( str -- )
+ "big-endian" get [ str-reverse ] unless
+ 0 swap [ swap 16 shift + ] str-each emit ;
+
+: (pack-string) ( n list -- )
+ #! Emit bytes for a string, with n characters per word.
+ [
+ 2dup str-length > [ dupd align-string ] when
+ emit-string
+ ] each drop ;
+
+: pack-string ( string -- )
+ char tuck swap split-n (pack-string) ;
+
+: string, ( string -- )
+ object-tag here-as swap
+ string-type >header emit
+ dup str-length emit
+ dup hashcode emit
+ pack-string
+ pad ;
+
+: 'string ( string -- pointer )
+ #! We pool strings so that each string is only written once
+ #! to the image
+ dup pooled-object dup [
+ nip
+ ] [
+ drop dup string, dup >r pool-object r>
+ ] 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 ;
+
+: 'plist ( word -- plist )
+ [
+ dup word-name "name" swons ,
+ dup word-vocabulary "vocabulary" swons ,
+ "parsing" word-property [ t "parsing" swons , ] when
+ ] make-list ' ;
+
+: (worddef,) ( word primitive parameter -- )
+ ' >r >r dup (word+) dup 'plist >r
+ word, pool-object
+ r> ( -- plist )
+ r> ( primitive -- ) emit
+ r> ( parameter -- ) emit
+ ( plist -- ) emit
+ 0 emit ( padding )
+ 0 emit ;
+
+: primitive, ( word primitive -- ) f (worddef,) ;
+: compound, ( word definition -- ) 1 swap (worddef,) ;
+
+( Arrays and vectors )
+
+: 'array ( list -- untagged )
+ [ ' ] map
+ here >r
+ array-type >header emit
+ dup length emit
+ ( elements -- ) [ emit ] each
+ pad r> ;
+
+: 'vector ( vector -- pointer )
+ dup vector>list 'array swap vector-length
+ object-tag here-as >r
+ vector-type >header emit
+ emit ( length )
+ emit ( array ptr )
+ pad r> ;
+
+( Cross-compile a reference to an object )
+
+: ' ( obj -- pointer )
+ [
+ [ fixnum? ] [ 'fixnum ]
+ [ bignum? ] [ 'bignum ]
+ [ ratio? ] [ 'ratio ]
+ [ complex? ] [ 'complex ]
+ [ word? ] [ 'word ]
+ [ cons? ] [ 'cons ]
+ [ string? ] [ 'string ]
+ [ vector? ] [ 'vector ]
+ [ t = ] [ drop "t" get ]
+ ! f is #define F RETAG(0,OBJECT_TYPE)
+ [ f = ] [ drop object-tag ]
+ [ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
+ ] cond ;
+
+( End of the image )
+
+: (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
+: (set-global) ( namespace -- ) ' global-offset fixup ;
+
+: global, ( -- )
+ "vocabularies" get "vocabularies"
+ namespace-buckets <hashtable>
+ dup >r set-hash r> (set-global) ;
+
+: end ( -- )
+ global,
+ fixup-words
+ here base - heap-size-offset fixup ;
+
+( Image output )
+
+: write-word ( word -- )
+ "64-bits" get [
+ "big-endian" get [
+ write-big-endian-64
+ ] [
+ write-little-endian-64
+ ] ifte
+ ] [
+ "big-endian" get [
+ write-big-endian-32
+ ] [
+ write-little-endian-32
+ ] ifte
+ ] ifte ;
+
+: write-image ( image file -- )
+ <filebw> [ [ write-word ] vector-each ] with-stream ;
+
+: with-minimal-image ( quot -- image )
+ [
+ 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.
+ 1000 <vector> "word-fixups" set
+ call
+ "image" get
+ ] with-scope ;
+
+: with-image ( quot -- image )
+ [ begin call end ] with-minimal-image ;
+
+: test-image ( quot -- ) with-image vector>list . ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: init
+USE: ansi
+USE: combinators
+USE: compiler
+USE: errors
+USE: inference
+USE: kernel
+USE: listener
+USE: lists
+USE: math
+USE: namespaces
+USE: parser
+USE: random
+USE: stack
+USE: streams
+USE: stdio
+USE: presentation
+USE: words
+USE: unparser
+
+: cli-args ( -- args ) 10 getenv ;
+
+: init-error-handler ( -- )
+ [ 1 exit* ] >c ( last resort )
+ [ default-error-handler 1 exit* ] >c
+ [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
+
+: warm-boot ( -- )
+ #! A fully bootstrapped image has this as the boot
+ #! quotation.
+ boot
+
+ init-error-handler
+ init-random
+ init-assembler
+
+ ! Some flags are *on* by default, unless user specifies
+ ! -no-<flag> CLI switch
+ t "user-init" set
+ t "interactive" set
+ t "ansi" set
+ t "compile" set
+
+ ! The first CLI arg is the image name.
+ cli-args uncons parse-command-line "image" set
+
+ "ansi" get [ "stdio" get <ansi-stream> "stdio" set ] when
+
+ "compile" get [ compile-all ] when
+
+ run-user-init ;
+
+[
+ warm-boot
+ "interactive" get [ init-listener ] when
+ 0 exit*
+] set-boot
+
+init-error-handler
+
+0 [ drop succ ] each-word unparse write " words" print
+
+"Inferring stack effects..." print
+[ 2 car ] [ ] catch
+0 [ unit try-infer [ succ ] when ] each-word
+unparse write " words have a stack effect" print
+
+"Bootstrapping is complete." print
+"Now, you can run ./f factor.image" print
+
+! Save a bit of space
+global [ "stdio" off ] bind
+
+garbage-collection
+"factor.image" save-image
+0 exit*
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: init
+USE: combinators
+USE: compiler
+USE: errors
+USE: kernel
+USE: namespaces
+USE: parser
+USE: stdio
+USE: streams
+USE: threads
+USE: words
+USE: vectors
+
+: boot ( -- )
+ #! Initialize an interpreter with the basic services.
+ init-errors
+ init-namespaces
+ init-threads
+ init-stdio
+ "HOME" os-env [ "." ] unless* "~" set
+ "/" "/" set
+ init-search-path ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 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: init
+USE: combinators
+USE: compiler
+USE: continuations
+USE: errors
+USE: files
+USE: listener
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: prettyprint
+USE: random
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+USE: words
+
+! This file is run as the last stage of boot.factor; it relies
+! on all other words already being defined.
+
+: ?run-file ( file -- )
+ dup exists? [ (run-file) ] [ drop ] ifte ;
+
+: run-user-init ( -- )
+ #! Run user init file if it exists
+ "user-init" get [
+ [ "~" get , "/" get , ".factor-" , "rc" , ] make-string
+ ?run-file
+ ] when ;
+
+: cli-var-param ( name value -- )
+ swap ":" split set-object-path ;
+
+: cli-param ( param -- )
+ #! Handle a command-line argument starting with '-' by
+ #! setting that variable to t, or if the argument is
+ #! prefixed with 'no-', setting the variable to f.
+ #!
+ #! Arguments containing = are handled differently; they
+ #! set the object path.
+ "=" split1 dup [
+ cli-var-param
+ ] [
+ drop dup "no-" str-head? dup [
+ f put drop
+ ] [
+ drop t put
+ ] ifte
+ ] ifte ;
+
+: cli-arg ( argument -- argument )
+ #! Handle a command-line argument. If the argument was
+ #! consumed, returns f. Otherwise returns the argument.
+ dup [
+ dup "-" str-head? dup [
+ cli-param drop f
+ ] [
+ drop
+ ] ifte
+ ] when ;
+
+: parse-switches ( args -- args )
+ [ cli-arg ] map ;
+
+: run-files ( args -- )
+ [ [ run-file ] when* ] each ;
+
+: parse-command-line ( args -- )
+ #! Parse command line arguments.
+ parse-switches run-files ;
USE: strings
USE: vectors
+! This is a very lightweight exception handling system.
+
+: catchstack* ( -- cs ) 6 getenv ;
+: catchstack ( -- cs ) catchstack* vector-clone ;
+: set-catchstack* ( cs -- ) 6 setenv ;
+: set-catchstack ( cs -- ) vector-clone set-catchstack* ;
+
+: init-errors ( -- )
+ 64 <vector> set-catchstack* ;
+
: >c ( catch -- ) catchstack* vector-push ;
: c> ( catch -- ) catchstack* vector-pop ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: streams
-USE: errors
-USE: kernel
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-
-: <extend-stream> ( stream -- stream )
- #! Create a stream that wraps another stream. Override some
- #! or all of the stream words.
- <stream> [
- "stdio" set
- ( -- string )
- [ read ] "freadln" set
- ( -- string )
- [ read1 ] "fread1" set
- ( count -- string )
- [ read# ] "fread#" set
- ( string -- )
- [ write ] "fwrite" set
- ( string style -- )
- [ write-attr ] "fwrite-attr" set
- ( -- )
- [ flush ] "fflush" set
- ( -- )
- [ "stdio" get fclose ] "fclose" set
- ( string -- )
- [ print ] "fprint" set
- ] extend ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: files
-USE: combinators
-USE: hashtables
-USE: lists
-USE: logic
-USE: namespaces
-USE: presentation
-USE: stack
-USE: stdio
-USE: strings
-
-: file-actions ( -- list )
- [
- [ "Push" | "" ]
- [ "Run file" | "run-file" ]
- [ "List directory" | "directory." ]
- [ "Change directory" | "cd" ]
- ] ;
-
-: set-mime-types ( assoc -- )
- "mime-types" global set-hash ;
-
-: mime-types ( -- assoc )
- "mime-types" global hash ;
-
-: file-extension ( filename -- extension )
- "." split cdr dup [ last ] when ;
-
-: mime-type ( filename -- mime-type )
- file-extension mime-types assoc [ "text/plain" ] unless* ;
-
-: dir-icon
- "/library/icons/Folder.png" ;
-
-: file-icon
- "/library/icons/File.png" ;
-
-: file-icon. ( path -- )
- directory? dir-icon file-icon ? write-icon ;
-
-: file-link. ( dir name -- )
- tuck "/" swap cat3 dup "file-link" swons swap
- file-actions <actions> "actions" swons
- t "underline" swons
- 3list write-attr ;
-
-: file. ( dir name -- )
- #! If "doc-root" set, create links relative to it.
- 2dup "/" swap cat3 file-icon. " " write file-link. terpri ;
-
-: directory. ( dir -- )
- #! If "doc-root" set, create links relative to it.
- dup directory [
- dup [ "." ".." ] contains? [
- drop
- ] [
- dupd file.
- ] ifte
- ] each drop ;
-
-: pwd cwd print ;
-: dir. cwd directory. ;
-
-[
- [ "html" | "text/html" ]
- [ "txt" | "text/plain" ]
-
- [ "gif" | "image/gif" ]
- [ "png" | "image/png" ]
- [ "jpg" | "image/jpeg" ]
- [ "jpeg" | "image/jpeg" ]
-
- [ "jar" | "application/octet-stream" ]
- [ "zip" | "application/octet-stream" ]
- [ "tgz" | "application/octet-stream" ]
- [ "tar.gz" | "application/octet-stream" ]
- [ "gz" | "application/octet-stream" ]
-
- [ "factor" | "application/x-factor" ]
- [ "factsp" | "application/x-factor-server-page" ]
-] set-mime-types
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: words
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: unparser
+
+SYMBOL: gensym-count
+
+: (gensym) ( -- name )
+ "G:" global [
+ gensym-count get succ dup gensym-count set
+ ] bind unparse cat2 ;
+
+: gensym ( -- word )
+ #! Return a word that is distinct from every other word, and
+ #! is not contained in any vocabulary.
+ (gensym) f (create) ;
+
+global [ 0 gensym-count set ] bind
2dup str-length 2 - >= [
2drop
] [
- >r succ dup 2 + r> substring
- catch-hex> [ >char , ] when*
+ >r succ dup 2 + r> substring catch-hex> [ , ] when*
] ifte ;
: url-decode-% ( index str -- index str )
--- /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: threads
+USE: combinators
+USE: continuations
+USE: errors
+USE: io-internals
+USE: kernel
+USE: lists
+USE: stack
+
+: in-thread ( quot -- )
+ #! Execute a quotation in a co-operative thread. The
+ #! quotation begins executing immediately, and execution
+ #! after the 'in-thread' call in the original thread
+ #! resumes when the quotation yields, either due to blocking
+ #! I/O or an explicit call to 'yield'.
+ [
+ schedule-thread
+ ! Clear stacks since we never go up from this point
+ { } set-catchstack
+ { } set-callstack
+ print-error
+ (yield)
+ ] callcc0 drop ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 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: init
-USE: combinators
-USE: compiler
-USE: continuations
-USE: errors
-USE: files
-USE: listener
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: prettyprint
-USE: random
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-USE: words
-
-! This file is run as the last stage of boot.factor; it relies
-! on all other words already being defined.
-
-: ?run-file ( file -- )
- dup exists? [ (run-file) ] [ drop ] ifte ;
-
-: run-user-init ( -- )
- #! Run user init file if it exists
- "user-init" get [
- [ "~" get , "/" get , ".factor-" , "rc" , ] make-string
- ?run-file
- ] when ;
-
-: cli-var-param ( name value -- )
- swap ":" split set-object-path ;
-
-: cli-param ( param -- )
- #! Handle a command-line argument starting with '-' by
- #! setting that variable to t, or if the argument is
- #! prefixed with 'no-', setting the variable to f.
- #!
- #! Arguments containing = are handled differently; they
- #! set the object path.
- "=" split1 dup [
- cli-var-param
- ] [
- drop dup "no-" str-head? dup [
- f put drop
- ] [
- drop t put
- ] ifte
- ] ifte ;
-
-: cli-arg ( argument -- argument )
- #! Handle a command-line argument. If the argument was
- #! consumed, returns f. Otherwise returns the argument.
- dup [
- dup "-" str-head? dup [
- cli-param drop f
- ] [
- drop
- ] ifte
- ] when ;
-
-: parse-switches ( args -- args )
- [ cli-arg ] map ;
-
-: run-files ( args -- )
- [ [ run-file ] when* ] each ;
-
-: parse-command-line ( args -- )
- #! Parse command line arguments.
- parse-switches run-files ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: ansi
+USE: combinators
+USE: lists
+USE: kernel
+USE: format
+USE: namespaces
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+
+! Some words for outputting ANSI colors.
+
+: black 0 ; inline
+: red 1 ; inline
+: green 2 ; inline
+: yellow 3 ; inline
+: blue 4 ; inline
+: magenta 5 ; inline
+: cyan 6 ; inline
+: white 7 ; inline
+
+: clear ( -- code )
+ #! Clear screen
+ "\e[2J\e[H" ; inline
+
+: reset ( -- code )
+ #! Reset ANSI color codes.
+ "\e[0m" ; inline
+
+: bold ( -- code )
+ #! Switch on boldface.
+ "\e[1m" ; inline
+
+: fg ( color -- code )
+ #! Set foreground color.
+ "\e[3" swap "m" cat3 ; inline
+
+: bg ( color -- code )
+ #! Set foreground color.
+ "\e[4" swap "m" cat3 ; inline
+
+: ansi-attrs ( style -- )
+ "bold" over assoc [ bold , ] when
+ "ansi-fg" over assoc [ fg , ] when*
+ "ansi-bg" over assoc [ bg , ] when*
+ drop ;
+
+: ansi-attr-string ( string style -- string )
+ [ ansi-attrs , reset , ] make-string ;
+
+: <ansi-stream> ( stream -- stream )
+ #! Wraps the given stream in an ANSI stream. ANSI streams
+ #! support the following character attributes:
+ #! bold - if not f, text is boldface.
+ #! ansi-fg - foreground color
+ #! ansi-bg - background color
+ <extend-stream> [
+ ( string style -- )
+ [ ansi-attr-string write ] "fwrite-attr" set
+ ] extend ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: streams
+USE: errors
+USE: kernel
+USE: namespaces
+USE: stack
+USE: stdio
+USE: strings
+
+: <extend-stream> ( stream -- stream )
+ #! Create a stream that wraps another stream. Override some
+ #! or all of the stream words.
+ <stream> [
+ "stdio" set
+ ( -- string )
+ [ read ] "freadln" set
+ ( -- string )
+ [ read1 ] "fread1" set
+ ( count -- string )
+ [ read# ] "fread#" set
+ ( string -- )
+ [ write ] "fwrite" set
+ ( string style -- )
+ [ write-attr ] "fwrite-attr" set
+ ( -- )
+ [ flush ] "fflush" set
+ ( -- )
+ [ "stdio" get fclose ] "fclose" set
+ ( string -- )
+ [ print ] "fprint" set
+ ] extend ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: files
+USE: combinators
+USE: hashtables
+USE: lists
+USE: logic
+USE: namespaces
+USE: presentation
+USE: stack
+USE: stdio
+USE: strings
+
+: exists? ( file -- ? )
+ stat >boolean ;
+
+: directory? ( file -- ? )
+ stat dup [ car ] when ;
+
+: directory ( dir -- list )
+ #! List a directory.
+ (directory) str-sort ;
+
+: file-length ( file -- length )
+ stat dup [ cdr cdr car ] when ;
+
+: file-actions ( -- list )
+ [
+ [ "Push" | "" ]
+ [ "Run file" | "run-file" ]
+ [ "List directory" | "directory." ]
+ [ "Change directory" | "cd" ]
+ ] ;
+
+: set-mime-types ( assoc -- )
+ "mime-types" global set-hash ;
+
+: mime-types ( -- assoc )
+ "mime-types" global hash ;
+
+: file-extension ( filename -- extension )
+ "." split cdr dup [ last ] when ;
+
+: mime-type ( filename -- mime-type )
+ file-extension mime-types assoc [ "text/plain" ] unless* ;
+
+: dir-icon
+ "/library/icons/Folder.png" ;
+
+: file-icon
+ "/library/icons/File.png" ;
+
+: file-icon. ( path -- )
+ directory? dir-icon file-icon ? write-icon ;
+
+: file-link. ( dir name -- )
+ tuck "/" swap cat3 dup "file-link" swons swap
+ file-actions <actions> "actions" swons
+ t "underline" swons
+ 3list write-attr ;
+
+: file. ( dir name -- )
+ #! If "doc-root" set, create links relative to it.
+ 2dup "/" swap cat3 file-icon. " " write file-link. terpri ;
+
+: directory. ( dir -- )
+ #! If "doc-root" set, create links relative to it.
+ dup directory [
+ dup [ "." ".." ] contains? [
+ drop
+ ] [
+ dupd file.
+ ] ifte
+ ] each drop ;
+
+: pwd cwd print ;
+: dir. cwd directory. ;
+
+[
+ [ "html" | "text/html" ]
+ [ "txt" | "text/plain" ]
+
+ [ "gif" | "image/gif" ]
+ [ "png" | "image/png" ]
+ [ "jpg" | "image/jpeg" ]
+ [ "jpeg" | "image/jpeg" ]
+
+ [ "jar" | "application/octet-stream" ]
+ [ "zip" | "application/octet-stream" ]
+ [ "tgz" | "application/octet-stream" ]
+ [ "tar.gz" | "application/octet-stream" ]
+ [ "gz" | "application/octet-stream" ]
+
+ [ "factor" | "application/x-factor" ]
+ [ "factsp" | "application/x-factor-server-page" ]
+] set-mime-types
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 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: logging
+
+USE: combinators
+USE: hashtables
+USE: namespaces
+USE: stack
+USE: streams
+USE: strings
+USE: unparser
+
+: log ( msg -- )
+ "log" get dup [ tuck fprint fflush ] [ 2drop ] ifte ;
+
+: log-error ( error -- )
+ "Error: " swap cat2 log ;
+
+: log-client ( -- )
+ "client" get [
+ "Accepted connection from " swap
+ "client" swap hash cat2 log
+ ] when* ;
+
+: with-logging ( quot -- )
+ [ "stdio" get "log" set call ] with-scope ;
+
+: with-log-file ( file quot -- )
+ [ swap <filecr> "log" set call ] with-scope ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: presentation
+USE: combinators
+USE: hashtables
+USE: kernel
+USE: lists
+USE: namespaces
+USE: stack
+USE: strings
+USE: unparser
+
+: <actions> ( path alist -- alist )
+ #! For each element of the alist, change the value to
+ #! path " " value
+ >r unparse r>
+ [ uncons >r over " " r> cat3 cons ] map nip ;
+
+! A style is an alist whose key/value pairs hold
+! significance to the 'fwrite-attr' word when applied to a
+! stream that supports attributed string output.
+
+: (style) ( name -- style ) "styles" get hash ;
+: default-style ( -- style ) "default" (style) ;
+: style ( name -- style ) (style) [ default-style ] unless* ;
+: set-style ( style name -- ) "styles" get set-hash ;
+
+<namespace> "styles" set
+
+[
+ [ "font" | "Monospaced" ]
+] "default" set-style
+
+[
+ [ "bold" | t ]
+] default-style append "prompt" set-style
+
+[
+ [ "ansi-fg" | "0" ]
+ [ "ansi-bg" | "2" ]
+ [ "fg" | [ 255 0 0 ] ]
+] default-style append "comments" set-style
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 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: stdio
+USE: math
+USE: stack
+USE: streams
+USE: strings
+
+: read-little-endian-32 ( -- word )
+ read1
+ read1 8 shift bitor
+ read1 16 shift bitor
+ read1 24 shift bitor ;
+
+: read-big-endian-32 ( -- word )
+ read1 24 shift
+ read1 16 shift bitor
+ read1 8 shift bitor
+ read1 bitor ;
+
+: byte7 ( num -- byte ) -56 shift HEX: ff bitand ;
+: byte6 ( num -- byte ) -48 shift HEX: ff bitand ;
+: byte5 ( num -- byte ) -40 shift HEX: ff bitand ;
+: byte4 ( num -- byte ) -32 shift HEX: ff bitand ;
+: byte3 ( num -- byte ) -24 shift HEX: ff bitand ;
+: byte2 ( num -- byte ) -16 shift HEX: ff bitand ;
+: byte1 ( num -- byte ) -8 shift HEX: ff bitand ;
+: byte0 ( num -- byte ) HEX: ff bitand ;
+
+: write-little-endian-64 ( word -- )
+ dup byte0 write
+ dup byte1 write
+ dup byte2 write
+ dup byte3 write
+ dup byte4 write
+ dup byte5 write
+ dup byte6 write
+ byte7 write ;
+
+: write-big-endian-64 ( word -- )
+ dup byte7 write
+ dup byte6 write
+ dup byte5 write
+ dup byte4 write
+ dup byte3 write
+ dup byte2 write
+ dup byte1 write
+ byte0 write ;
+
+: write-little-endian-32 ( word -- )
+ dup byte0 write
+ dup byte1 write
+ dup byte2 write
+ byte3 write ;
+
+: write-big-endian-32 ( word -- )
+ dup byte3 write
+ dup byte2 write
+ dup byte1 write
+ byte0 write ;
+
+: write-little-endian-16 ( char -- )
+ dup byte0 write
+ byte1 write ;
+
+: write-big-endian-16 ( char -- )
+ dup byte1 write
+ byte0 write ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 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: streams
+DEFER: <extend-stream>
+
+IN: stdio
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: namespaces
+USE: stack
+USE: streams
+
+: flush ( -- )
+ "stdio" get fflush ;
+
+: read ( -- string )
+ "stdio" get freadln ;
+
+: read1 ( count -- string )
+ "stdio" get fread1 ;
+
+: read# ( count -- string )
+ "stdio" get fread# ;
+
+: write ( string -- )
+ "stdio" get fwrite ;
+
+: write-attr ( string style -- )
+ #! Write an attributed string to standard output.
+ "stdio" get fwrite-attr ;
+
+: write-icon ( resource -- )
+ #! Write an icon. Eg, /library/icons/File.png
+ "icon" swons unit "" swap write-attr ;
+
+: print ( string -- )
+ "stdio" get fprint ;
+
+: terpri ( -- )
+ #! Print a newline to standard output.
+ "\n" write ;
+
+: close ( -- )
+ "stdio" get fclose ;
+
+: with-stream ( stream quot -- )
+ [ swap "stdio" set [ close rethrow ] catch ] with-scope ;
+
+: with-string ( quot -- str )
+ #! Execute a quotation, and push a string containing all
+ #! text printed by the quotation.
+ 1024 <string-output-stream> [
+ call "stdio" get stream>str
+ ] with-stream ;
+
+: <stdio-stream> ( stream -- stream )
+ #! We disable fclose on stdio so that various tricks like
+ #! with-stream can work.
+ <extend-stream> [
+ ( string -- )
+ [ write "\n" write flush ] "fprint" set
+
+ [ ] "fclose" set
+ ] extend ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 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: streams
+USE: combinators
+USE: errors
+USE: kernel
+USE: namespaces
+USE: stack
+USE: strings
+
+! Generic functions, of sorts...
+
+: fflush ( stream -- )
+ [ "fflush" get call ] bind ;
+
+: freadln ( stream -- string )
+ [ "freadln" get call ] bind ;
+
+: fread1 ( stream -- string )
+ [ "fread1" get call ] bind ;
+
+: fread# ( count stream -- string )
+ [ "fread#" get call ] bind ;
+
+: fprint ( string stream -- )
+ [ "fprint" get call ] bind ;
+
+: fwrite ( string stream -- )
+ [ "fwrite" get call ] bind ;
+
+: fwrite-attr ( string style stream -- )
+ #! Write an attributed string to the given stream.
+ #! Supported keys depend on the type of stream.
+ [ "fwrite-attr" get call ] bind ;
+
+: fclose ( stream -- )
+ [ "fclose" get call ] bind ;
+
+: <stream> ( -- stream )
+ #! Create a stream object.
+ <namespace> [
+ ( -- string )
+ [ "freadln not implemented." throw ] "freadln" set
+ ( -- string )
+ [
+ 1 namespace fread# dup f-or-"" [
+ 0 swap str-nth
+ ] unless
+ ] "fread1" set
+ ( count -- string )
+ [ "fread# not implemented." throw ] "fread#" set
+ ( string -- )
+ [ "fwrite not implemented." throw ] "fwrite" set
+ ( string style -- )
+ [ drop namespace fwrite ] "fwrite-attr" set
+ ( -- )
+ [ ] "fflush" set
+ ( -- )
+ [ ] "fclose" set
+ ( string -- )
+ [
+ namespace fwrite
+ "\n" namespace fwrite
+ ] "fprint" set
+ ] extend ;
+
+: <string-output-stream> ( size -- stream )
+ #! Creates a new stream for writing to a string buffer.
+ <stream> [
+ <sbuf> "buf" set
+ ( string -- )
+ [ "buf" get sbuf-append ] "fwrite" set
+ ] extend ;
+
+: stream>str ( stream -- string )
+ #! Returns the string written to the given string output
+ #! stream.
+ [ "buf" get ] bind sbuf>str ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: presentation
+USE: combinators
+USE: hashtables
+USE: lists
+USE: kernel
+USE: namespaces
+USE: stack
+USE: words
+
+: vocab-style ( vocab -- style )
+ #! Each vocab has a style object specifying how words are
+ #! to be printed.
+ "vocabularies" style hash ;
+
+: set-vocab-style ( style vocab -- )
+ >r default-style append r> "vocabularies" style set-hash ;
+
+: word-style ( word -- style )
+ word-vocabulary [ vocab-style ] [ default-style ] ifte* ;
+
+<namespace> "vocabularies" set-style
+
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 204 0 0 ] ]
+] "arithmetic" set-vocab-style
+[
+ [ "ansi-fg" | "3" ]
+ [ "fg" | [ 255 132 0 ] ]
+] "combinators" set-vocab-style
+[
+ [ "ansi-fg" | "5" ]
+ [ "fg" | [ 102 0 204 ] ]
+] "continuations" set-vocab-style
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 255 0 0 ] ]
+] "errors" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 153 102 255 ] ]
+] "hashtables" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 0 102 153 ] ]
+] "lists" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 0 153 102 ] ]
+] "logic" set-vocab-style
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 204 0 0 ] ]
+] "math" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 0 153 255 ] ]
+] "namespaces" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "parser" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "prettyprint" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 0 0 0 ] ]
+] "stack" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 204 0 204 ] ]
+] "stdio" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 102 0 204 ] ]
+] "streams" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 255 0 204 ] ]
+] "strings" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "unparser" set-vocab-style
+[
+ [ "ansi-fg" | "3" ]
+ [ "fg" | [ 2 185 2 ] ]
+] "vectors" set-vocab-style
+[
+ [ "fg" | [ 128 128 128 ] ]
+] "syntax" set-vocab-style
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: jedit
-USE: combinators
-USE: errors
-USE: kernel
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-USE: words
-
-: resource-path ( -- path )
- global [ "resource-path" get ] bind [ "." ] unless* ;
-
-: word-file ( path -- dir file )
- dup [
- dup "resource:/" str-head? dup [
- nip resource-path swap
- ] [
- swap ( f file )
- ] ifte
- ] [
- f
- ] ifte ;
-
-: word-line/file ( word -- line dir file )
- #! Note that line numbers here start from 1
- dup "line" word-property swap "file" word-property
- word-file ;
-
-: jedit ( word -- )
- word-line/file dup [
- jedit-line/file
- ] [
- 3drop "Unknown source" print
- ] ifte ;
--- /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: vectors
+DEFER: vector=
+DEFER: vector-hashcode
+
+IN: kernel
+
+USE: combinators
+USE: lists
+USE: math
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+USE: vectors
+
+: cpu ( -- arch )
+ #! Returns one of "x86" or "unknown".
+ 7 getenv ;
+
+! The 'fake vtable' used here speeds things up a lot.
+! It is quite clumsy, however. A higher-level CLOS-style
+! 'generic words' system will be built later.
+
+: generic ( obj vtable -- )
+ >r dup type r> vector-nth execute ;
+
+: 2generic ( n n vtable -- )
+ >r 2dup arithmetic-type r> vector-nth execute ;
+
+: default-hashcode drop 0 ;
+
+: hashcode ( obj -- hash )
+ #! If two objects are =, they must have equal hashcodes.
+ {
+ nop ! 0
+ word-hashcode ! 1
+ cons-hashcode ! 2
+ default-hashcode ! 3
+ >fixnum ! 4
+ >fixnum ! 5
+ default-hashcode ! 6
+ default-hashcode ! 7
+ default-hashcode ! 8
+ >fixnum ! 9
+ >fixnum ! 10
+ vector-hashcode ! 11
+ str-hashcode ! 12
+ sbuf-hashcode ! 13
+ default-hashcode ! 14
+ default-hashcode ! 15
+ default-hashcode ! 16
+ } generic ;
+
+IN: math DEFER: number= ( defined later... )
+IN: kernel
+: = ( obj obj -- ? )
+ #! Push t if a is isomorphic to b.
+ {
+ number= ! 0
+ eq? ! 1
+ cons= ! 2
+ eq? ! 3
+ number= ! 4
+ number= ! 5
+ eq? ! 6
+ eq? ! 7
+ eq? ! 8
+ number= ! 9
+ number= ! 10
+ vector= ! 11
+ str= ! 12
+ sbuf= ! 13
+ eq? ! 14
+ eq? ! 15
+ eq? ! 16
+ } generic ;
+
+: 2= ( a b c d -- ? )
+ #! Test if a = c, b = d.
+ rot = [ = ] [ 2drop f ] ifte ;
+
+: set-boot ( quot -- )
+ #! Set the boot quotation.
+ 8 setenv ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 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: logging
-
-USE: combinators
-USE: hashtables
-USE: namespaces
-USE: stack
-USE: streams
-USE: strings
-USE: unparser
-
-: log ( msg -- )
- "log" get dup [ tuck fprint fflush ] [ 2drop ] ifte ;
-
-: log-error ( error -- )
- "Error: " swap cat2 log ;
-
-: log-client ( -- )
- "client" get [
- "Accepted connection from " swap
- "client" swap hash cat2 log
- ] when* ;
-
-: with-logging ( quot -- )
- [ "stdio" get "log" set call ] with-scope ;
-
-: with-log-file ( file quot -- )
- [ swap <filecr> "log" set call ] with-scope ;
--- /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.
+
+IN: math
+USE: combinators
+USE: errors
+USE: kernel
+USE: stack
+USE: vectors
+USE: words
+
+DEFER: number=
+
+: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
+: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
+
+: reduce ( x y -- x' y' )
+ dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
+: ratio ( x y -- x/y ) reduce fraction> ;
+: >fraction ( a/b -- a b ) dup numerator swap denominator ;
+: 2>fraction ( a/b c/d -- a c b d )
+ [ swap numerator swap numerator ] 2keep
+ swap denominator swap denominator ;
+
+: ratio= ( a/b c/d -- ? )
+ 2>fraction number= [ number= ] [ 2drop f ] ifte ;
+: ratio-scale ( a/b c/d -- a*d b*c )
+ 2>fraction >r * swap r> * swap ;
+: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
+: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
+: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
+: ratio* ( x y -- x*y ) 2>fraction * >r * r> ratio ;
+: ratio/ ( x y -- x/y ) ratio-scale ratio ;
+: ratio/f ( x y -- x/y ) ratio-scale /f ;
+
+: ratio< ( x y -- ? ) ratio-scale < ;
+: ratio<= ( x y -- ? ) ratio-scale <= ;
+: ratio> ( x y -- ? ) ratio-scale > ;
+: ratio>= ( x y -- ? ) ratio-scale >= ;
+
+: >rect ( x -- x:re x: im ) dup real swap imaginary ;
+: 2>rect ( x y -- x:re y:re x:im y:im )
+ [ swap real swap real ] 2keep
+ swap imaginary swap imaginary ;
+
+: complex= ( x y -- ? )
+ 2>rect number= [ number= ] [ 2drop f ] ifte ;
+
+: complex+ ( x y -- x+y ) 2>rect + >r + r> rect> ;
+: complex- ( x y -- x-y ) 2>rect - >r - r> rect> ;
+: complex*re ( x y -- x:re * y:re x:im * r:im )
+ 2>rect * >r * r> ;
+: complex*im ( x y -- x:im * y:re x:re * y:im )
+ 2>rect >r * swap r> * ;
+: complex* ( x y -- x*y )
+ 2dup complex*re - -rot complex*im + rect> ;
+: abs^2 ( x -- y ) >rect sq swap sq + ;
+: (complex/) ( x y -- r i m )
+ #! r = x:re * y:re + x:im * y:im
+ #! i = x:im * y:re - x:re * y:im
+ #! m = y:re * y:re + y:im * y:im
+ dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
+: complex/ ( x y -- x/y )
+ (complex/) tuck / >r / r> rect> ;
+: complex/f ( x y -- x/y )
+ (complex/) tuck /f >r /f r> rect> ;
+
+: no-method ( -- )
+ "No applicable method" throw ;
+
+: (not-=) ( x y -- f )
+ 2drop f ;
+
+: number= ( x y -- ? )
+ {
+ fixnum=
+ (not-=)
+ (not-=)
+ (not-=)
+ ratio=
+ complex=
+ (not-=)
+ (not-=)
+ (not-=)
+ bignum=
+ float=
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ } 2generic ;
+
+: + ( x y -- x+y )
+ {
+ fixnum+
+ no-method
+ no-method
+ no-method
+ ratio+
+ complex+
+ no-method
+ no-method
+ no-method
+ bignum+
+ float+
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: - ( x y -- x-y )
+ {
+ fixnum-
+ no-method
+ no-method
+ no-method
+ ratio-
+ complex-
+ no-method
+ no-method
+ no-method
+ bignum-
+ float-
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: * ( x y -- x*y )
+ {
+ fixnum*
+ no-method
+ no-method
+ no-method
+ ratio*
+ complex*
+ no-method
+ no-method
+ no-method
+ bignum*
+ float*
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: / ( x y -- x/y )
+ {
+ ratio
+ no-method
+ no-method
+ no-method
+ ratio/
+ complex/
+ no-method
+ no-method
+ no-method
+ ratio
+ float/f
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: /i ( x y -- x/y )
+ {
+ fixnum/i
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum/i
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: /f ( x y -- x/y )
+ {
+ fixnum/f
+ no-method
+ no-method
+ no-method
+ ratio/f
+ complex/f
+ no-method
+ no-method
+ no-method
+ bignum/f
+ float/f
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: mod ( x y -- x%y )
+ {
+ fixnum-mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: /mod ( x y -- x/y x%y )
+ {
+ fixnum/mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum/mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: bitand ( x y -- x&y )
+ {
+ fixnum-bitand
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitand
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: bitor ( x y -- x|y )
+ {
+ fixnum-bitor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: bitxor ( x y -- x^y )
+ {
+ fixnum-bitxor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitxor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: bitnot ( x -- ~x )
+ {
+ fixnum-bitnot
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitnot
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } generic ;
+
+: shift ( x n -- x<<n )
+ {
+ fixnum-shift
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-shift
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: < ( x y -- ? )
+ {
+ fixnum<
+ no-method
+ no-method
+ no-method
+ ratio<
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum<
+ float<
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: <= ( x y -- ? )
+ {
+ fixnum<=
+ no-method
+ no-method
+ no-method
+ ratio<=
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum<=
+ float<=
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: > ( x y -- ? )
+ {
+ fixnum>
+ no-method
+ no-method
+ no-method
+ ratio>
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum>
+ float>
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
+
+: >= ( x y -- ? )
+ {
+ fixnum>=
+ no-method
+ no-method
+ no-method
+ ratio>=
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum>=
+ float>=
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ } 2generic ;
! bind ( namespace quot -- ) executes a quotation with a
! namespace pushed on the namespace stack.
+: namestack ( -- ns ) 3 getenv ;
+: set-namestack ( ns -- ) 3 setenv ;
+
: namespace ( -- namespace )
#! Push the current namespace.
namestack car ; inline
+: >n ( namespace -- n:namespace )
+ #! Push a namespace on the namespace stack.
+ namestack cons set-namestack ; inline
+
+: n> ( n:namespace -- namespace )
+ #! Pop the top of the namespace stack.
+ namestack uncons set-namestack ; inline
+
+: global ( -- g ) 4 getenv ;
+: set-global ( g -- ) 4 setenv ;
+
+: init-namespaces ( -- )
+ global >n global "global" set ;
+
+: namespace-buckets 23 ;
+
+: <namespace> ( -- n )
+ #! Create a new namespace.
+ namespace-buckets <hashtable> ;
+
+: (get) ( var ns -- value )
+ #! Internal word for searching the namestack.
+ dup [
+ 2dup car hash* dup [
+ nip nip cdr ( found )
+ ] [
+ drop cdr (get) ( keep looking )
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+: get ( variable -- value )
+ #! Push the value of a variable by searching the namestack
+ #! from the top down.
+ namestack (get) ;
+
+: set ( value variable -- ) namespace set-hash ;
+: put ( variable value -- ) swap set ;
+
+: bind ( namespace quot -- )
+ #! Execute a quotation with a namespace on the namestack.
+ swap >n call n> drop ; inline
+
: with-scope ( quot -- )
#! Execute a quotation with a new namespace on the
#! namestack.
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: init
-USE: combinators
-USE: kernel
-USE: lists
-USE: parser
-USE: stack
-USE: stdio
-
-"Cold boot in progress..." print
-[
- "/library/platform/native/kernel.factor"
- "/library/platform/native/stack.factor"
- "/library/platform/native/types.factor"
- "/library/cons.factor"
- "/library/combinators.factor"
- "/library/logic.factor"
- "/library/platform/native/vectors.factor"
- "/library/vector-combinators.factor"
- "/library/lists.factor"
- "/library/assoc.factor"
- "/library/math/arithmetic.factor"
- "/library/math/math-combinators.factor"
- "/library/vectors.factor"
- "/library/platform/native/strings.factor"
- "/library/strings.factor"
- "/library/hashtables.factor"
- "/library/platform/native/namespaces.factor"
- "/library/namespaces.factor"
- "/library/math/namespace-math.factor"
- "/library/list-namespaces.factor"
- "/library/sbuf.factor"
- "/library/continuations.factor"
- "/library/platform/native/errors.factor"
- "/library/errors.factor"
- "/library/platform/native/threads.factor"
- "/library/stream.factor"
- "/library/platform/native/io-internals.factor"
- "/library/platform/native/stream.factor"
- "/library/stdio.factor"
- "/library/extend-stream.factor"
- "/library/platform/native/words.factor"
- "/library/words.factor"
- "/library/platform/native/vocabularies.factor"
- "/library/syntax/parse-numbers.factor"
- "/library/syntax/parser.factor"
- "/library/syntax/parse-syntax.factor"
- "/library/syntax/parse-stream.factor"
-
- "/library/format.factor"
- "/library/syntax/unparser.factor"
- "/library/presentation.factor"
- "/library/vocabulary-style.factor"
- "/library/syntax/prettyprint.factor"
- "/library/syntax/see.factor"
- "/library/platform/native/debugger.factor"
- "/library/tools/debugger.factor"
- "/library/platform/native/init.factor"
-
- "/library/math/constants.factor"
- "/library/math/math.factor"
- "/library/platform/native/math.factor"
- "/library/math/pow.factor"
- "/library/math/trig-hyp.factor"
- "/library/math/arc-trig-hyp.factor"
-
- "/library/platform/native/in-thread.factor"
- "/library/platform/native/network.factor"
- "/library/logging.factor"
- "/library/platform/native/random.factor"
- "/library/random.factor"
- "/library/stdio-binary.factor"
- "/library/platform/native/files.factor"
- "/library/files.factor"
- "/library/eval-catch.factor"
- "/library/tools/listener.factor"
- "/library/tools/inspector.factor"
- "/library/tools/word-tools.factor"
- "/library/test/test.factor"
- "/library/ansi.factor"
- "/library/tools/telnetd.factor"
- "/library/tools/jedit-wire.factor"
- "/library/platform/native/profiler.factor"
- "/library/platform/native/heap-stats.factor"
- "/library/platform/native/gensym.factor"
- "/library/tools/interpreter.factor"
- "/library/tools/inference.factor"
-
- "/library/tools/image.factor"
- "/library/tools/cross-compiler.factor"
- "/library/platform/native/cross-compiler.factor"
-
- "/library/httpd/url-encoding.factor"
- "/library/httpd/html-tags.factor"
- "/library/httpd/html.factor"
- "/library/httpd/http-common.factor"
- "/library/httpd/responder.factor"
- "/library/httpd/httpd.factor"
- "/library/httpd/file-responder.factor"
- "/library/httpd/inspect-responder.factor"
- "/library/httpd/test-responder.factor"
- "/library/httpd/quit-responder.factor"
- "/library/httpd/resource-responder.factor"
- "/library/httpd/default-responders.factor"
-
- "/library/tools/jedit.factor"
-
- "/library/platform/native/primitives.factor"
-
- "/library/init.factor"
-] [
- dup print
- run-resource
-] each
-
-cpu "x86" = [
- [
- "/library/compiler/assembler.factor"
- "/library/compiler/assembly-x86.factor"
- "/library/compiler/compiler-macros.factor"
- "/library/compiler/compiler.factor"
- "/library/compiler/ifte.factor"
- "/library/compiler/generic.factor"
- "/library/compiler/stack.factor"
- "/library/compiler/interpret-only.factor"
- "/library/compiler/alien-types.factor"
- "/library/compiler/alien-macros.factor"
- "/library/compiler/alien.factor"
-
- "/library/sdl/sdl.factor"
- "/library/sdl/sdl-video.factor"
- "/library/sdl/sdl-event.factor"
- "/library/sdl/sdl-gfx.factor"
- "/library/sdl/sdl-keysym.factor"
- "/library/sdl/sdl-utils.factor"
- "/library/sdl/hsv.factor"
- ] [
- dup print
- run-resource
- ] each
-] [
- "/library/compiler/dummy-compiler.factor" dup print run-resource
-] ifte
-
-"/library/platform/native/init-stage2.factor" dup print 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.
-
-USE: lists
-USE: image
-USE: parser
-
-primitives,
-[
- "/library/platform/native/kernel.factor"
- "/library/platform/native/stack.factor"
- "/library/platform/native/types.factor"
- "/library/math/math.factor"
- "/library/cons.factor"
- "/library/combinators.factor"
- "/library/logic.factor"
- "/library/platform/native/vectors.factor"
- "/library/vector-combinators.factor"
- "/library/lists.factor"
- "/library/assoc.factor"
- "/library/math/arithmetic.factor"
- "/library/math/math-combinators.factor"
- "/library/vectors.factor"
- "/library/platform/native/strings.factor"
- "/library/strings.factor"
- "/library/hashtables.factor"
- "/library/platform/native/namespaces.factor"
- "/library/namespaces.factor"
- "/library/math/namespace-math.factor"
- "/library/list-namespaces.factor"
- "/library/sbuf.factor"
- "/library/continuations.factor"
- "/library/platform/native/errors.factor"
- "/library/errors.factor"
- "/library/platform/native/threads.factor"
- "/library/stream.factor"
- "/library/platform/native/io-internals.factor"
- "/library/platform/native/stream.factor"
- "/library/stdio.factor"
- "/library/extend-stream.factor"
- "/library/platform/native/words.factor"
- "/library/words.factor"
- "/library/platform/native/vocabularies.factor"
- "/library/syntax/parse-numbers.factor"
- "/library/syntax/parser.factor"
- "/library/syntax/parse-syntax.factor"
- "/library/syntax/parse-stream.factor"
- "/library/platform/native/math.factor"
- "/library/platform/native/init.factor"
-] [
- cross-compile-resource
-] each
-
-version,
-
-IN: init
-DEFER: boot
-
-[
- boot
- "/library/platform/native/boot-stage2.factor" run-resource
-] (set-boot)
+++ /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: namespaces
-USE: parser
-
-: cross-compile-resource ( resource -- )
- [
- ! Change behavior of ;
- [ compound, ] ";-hook" set
- run-resource
- ] with-scope ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: errors
-USE: combinators
-USE: continuations
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: strings
-USE: unparser
-USE: vectors
-USE: words
-
-: expired-error ( obj -- )
- "Object did not survive image save/load: " write . ;
-
-: io-task-twice-error ( obj -- )
- "Attempting to perform two simultaneous I/O operations on "
- write . ;
-
-: no-io-tasks-error ( obj -- )
- "No I/O tasks" print ;
-
-: undefined-word-error ( obj -- )
- "Undefined word: " write . ;
-
-: incompatible-port-error ( obj -- )
- "Unsuitable port for operation: " write . ;
-
-: io-error ( list -- )
- "I/O error in kernel function " write
- unswons write ": " write car print ;
-
-: type-check-error ( list -- )
- "Type check error" print
- uncons car dup "Object: " write .
- "Object type: " write type type-name print
- "Expected type: " write type-name print ;
-
-: array-range-error ( list -- )
- "Array range check error" print
- unswons "Object: " write .
- uncons car "Maximum index: " write .
- "Requested index: " write . ;
-
-: float-format-error ( list -- )
- "Invalid floating point literal format: " write . ;
-
-: signal-error ( obj -- )
- "Operating system signal " write . ;
-
-: negative-array-size-error ( obj -- )
- "Cannot allocate array with negative size " write . ;
-
-: bad-primitive-error ( obj -- )
- "Bad primitive number: " write . ;
-
-: c-string-error ( obj -- )
- "Cannot convert to C string: " write . ;
-
-: ffi-disabled-error ( obj -- )
- drop "Recompile Factor with #define FFI." print ;
-
-: ffi-error ( obj -- )
- "FFI: " write print ;
-
-: port-closed-error ( obj -- )
- "Port closed: " write . ;
-
-: kernel-error. ( obj n -- str )
- {
- expired-error
- io-task-twice-error
- no-io-tasks-error
- incompatible-port-error
- io-error
- undefined-word-error
- type-check-error
- array-range-error
- float-format-error
- signal-error
- negative-array-size-error
- bad-primitive-error
- c-string-error
- ffi-disabled-error
- ffi-error
- port-closed-error
- } vector-nth execute ;
-
-: kernel-error? ( obj -- ? )
- dup cons? [ uncons cons? swap fixnum? and ] [ drop f ] ifte ;
-
-: error. ( error -- str )
- dup kernel-error? [
- uncons car swap kernel-error.
- ] [
- dup string? [ print ] [ . ] ifte
- ] ifte ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: errors
-USE: kernel
-USE: vectors
-
-! This is a very lightweight exception handling system.
-
-: catchstack* ( -- cs ) 6 getenv ;
-: catchstack ( -- cs ) catchstack* vector-clone ;
-: set-catchstack* ( cs -- ) 6 setenv ;
-: set-catchstack ( cs -- ) vector-clone set-catchstack* ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: files
-USE: combinators
-USE: io-internals
-USE: lists
-USE: logic
-USE: stack
-USE: strings
-
-: exists? ( file -- ? )
- stat >boolean ;
-
-: directory? ( file -- ? )
- stat dup [ car ] when ;
-
-: directory ( dir -- list )
- #! List a directory.
- (directory) str-sort ;
-
-: file-length ( file -- length )
- stat dup [ cdr cdr car ] when ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: words
-USE: math
-USE: namespaces
-USE: stack
-USE: strings
-USE: unparser
-
-SYMBOL: gensym-count
-
-: (gensym) ( -- name )
- "G:" global [
- gensym-count get succ dup gensym-count set
- ] bind unparse cat2 ;
-
-: gensym ( -- word )
- #! Return a word that is distinct from every other word, and
- #! is not contained in any vocabulary.
- (gensym) f (create) ;
-
-global [ 0 gensym-count set ] bind
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: kernel
-USE: combinators
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: words
-USE: vectors
-USE: unparser
-
-: heap-stat. ( type instances bytes -- )
- dup 0 = [
- 3drop
- ] [
- rot type-name write ": " write
- unparse write " bytes, " write
- unparse write " instances" print
- ] ifte ;
-
-: heap-stats. ( -- )
- #! Print heap allocation breakdown.
- 0 heap-stats [ dupd uncons heap-stat. succ ] each drop ;
+++ /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: threads
-USE: combinators
-USE: continuations
-USE: errors
-USE: io-internals
-USE: kernel
-USE: lists
-USE: stack
-
-: in-thread ( quot -- )
- #! Execute a quotation in a co-operative thread. The
- #! quotation begins executing immediately, and execution
- #! after the 'in-thread' call in the original thread
- #! resumes when the quotation yields, either due to blocking
- #! I/O or an explicit call to 'yield'.
- [
- schedule-thread
- ! Clear stacks since we never go up from this point
- { } set-catchstack
- { } set-callstack
- print-error
- (yield)
- ] callcc0 drop ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: init
-USE: ansi
-USE: combinators
-USE: compiler
-USE: errors
-USE: inference
-USE: kernel
-USE: listener
-USE: lists
-USE: math
-USE: namespaces
-USE: parser
-USE: random
-USE: stack
-USE: streams
-USE: stdio
-USE: presentation
-USE: words
-USE: unparser
-
-: cli-args ( -- args ) 10 getenv ;
-
-: init-error-handler ( -- )
- [ 1 exit* ] >c ( last resort )
- [ default-error-handler 1 exit* ] >c
- [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) ;
-
-: warm-boot ( -- )
- #! A fully bootstrapped image has this as the boot
- #! quotation.
- boot
-
- init-error-handler
- init-random
- init-assembler
-
- ! Some flags are *on* by default, unless user specifies
- ! -no-<flag> CLI switch
- t "user-init" set
- t "interactive" set
- t "ansi" set
- t "compile" set
-
- ! The first CLI arg is the image name.
- cli-args uncons parse-command-line "image" set
-
- "ansi" get [ "stdio" get <ansi-stream> "stdio" set ] when
-
- "compile" get [ compile-all ] when
-
- run-user-init ;
-
-[
- warm-boot
- "interactive" get [ init-listener ] when
- 0 exit*
-] set-boot
-
-init-error-handler
-
-0 [ drop succ ] each-word unparse write " words" print
-
-"Inferring stack effects..." print
-[ 2 car ] [ ] catch
-0 [ unit try-infer [ succ ] when ] each-word
-unparse write " words have a stack effect" print
-
-"Bootstrapping is complete." print
-"Now, you can run ./f factor.image" print
-
-! Save a bit of space
-global [ "stdio" off ] bind
-
-garbage-collection
-"factor.image" save-image
-0 exit*
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: init
-USE: combinators
-USE: compiler
-USE: errors
-USE: kernel
-USE: namespaces
-USE: parser
-USE: stdio
-USE: streams
-USE: threads
-USE: words
-USE: vectors
-
-: init-errors ( -- )
- 64 <vector> set-catchstack* ;
-
-: boot ( -- )
- #! Initialize an interpreter with the basic services.
- init-errors
- init-namespaces
- init-threads
- init-stdio
- "HOME" os-env [ "." ] unless* "~" set
- "/" "/" set
- init-search-path ;
+++ /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: io-internals
-USE: combinators
-USE: continuations
-USE: kernel
-USE: namespaces
-USE: stack
-USE: strings
-USE: threads
-
-: stdin 0 getenv ;
-: stdout 1 getenv ;
-
-: blocking-flush ( port -- )
- [ add-write-io-task (yield) ] callcc0 drop ;
-
-: wait-to-write ( len port -- )
- tuck can-write? [ drop ] [ blocking-flush ] ifte ;
-
-: blocking-write ( str port -- )
- over
- dup string? [ str-length ] [ drop 1 ] ifte
- over wait-to-write write-fd-8 ;
-
-: blocking-fill ( port -- )
- [ add-read-line-io-task (yield) ] callcc0 drop ;
-
-: wait-to-read-line ( port -- )
- dup can-read-line? [ drop ] [ blocking-fill ] ifte ;
-
-: blocking-read-line ( port -- line )
- dup wait-to-read-line read-line-fd-8 dup [ sbuf>str ] when ;
-
-: fill-fd# ( count port -- )
- [ add-read-count-io-task (yield) ] callcc0 2drop ;
-
-: wait-to-read# ( count port -- )
- 2dup can-read-count? [ 2drop ] [ fill-fd# ] ifte ;
-
-: blocking-read# ( count port -- str )
- 2dup wait-to-read# read-count-fd-8 dup [ sbuf>str ] when ;
-
-: wait-to-accept ( socket -- )
- [ add-accept-io-task (yield) ] callcc0 drop ;
-
-: blocking-accept ( socket -- host port in out )
- dup wait-to-accept accept-fd ;
-
-: blocking-copy ( in out -- )
- [ add-copy-io-task (yield) ] callcc0
- pending-io-error pending-io-error ;
+++ /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: vectors
-DEFER: vector=
-DEFER: vector-hashcode
-
-IN: kernel
-
-USE: combinators
-USE: lists
-USE: math
-USE: stack
-USE: strings
-USE: vectors
-USE: words
-USE: vectors
-
-: cpu ( -- arch )
- #! Returns one of "x86" or "unknown".
- 7 getenv ;
-
-! The 'fake vtable' used here speeds things up a lot.
-! It is quite clumsy, however. A higher-level CLOS-style
-! 'generic words' system will be built later.
-
-: generic ( obj vtable -- )
- >r dup type r> vector-nth execute ;
-
-: 2generic ( n n vtable -- )
- >r 2dup arithmetic-type r> vector-nth execute ;
-
-: default-hashcode drop 0 ;
-
-: hashcode ( obj -- hash )
- #! If two objects are =, they must have equal hashcodes.
- {
- nop ! 0
- word-hashcode ! 1
- cons-hashcode ! 2
- default-hashcode ! 3
- >fixnum ! 4
- >fixnum ! 5
- default-hashcode ! 6
- default-hashcode ! 7
- default-hashcode ! 8
- >fixnum ! 9
- >fixnum ! 10
- vector-hashcode ! 11
- str-hashcode ! 12
- sbuf-hashcode ! 13
- default-hashcode ! 14
- default-hashcode ! 15
- default-hashcode ! 16
- } generic ;
-
-IN: math DEFER: number= ( defined later... )
-IN: kernel
-: = ( obj obj -- ? )
- #! Push t if a is isomorphic to b.
- {
- number= ! 0
- eq? ! 1
- cons= ! 2
- eq? ! 3
- number= ! 4
- number= ! 5
- eq? ! 6
- eq? ! 7
- eq? ! 8
- number= ! 9
- number= ! 10
- vector= ! 11
- str= ! 12
- sbuf= ! 13
- eq? ! 14
- eq? ! 15
- eq? ! 16
- } generic ;
-
-: 2= ( a b c d -- ? )
- #! Test if a = c, b = d.
- rot = [ = ] [ 2drop f ] ifte ;
-
-: set-boot ( quot -- )
- #! Set the boot quotation.
- 8 setenv ;
+++ /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.
-
-IN: math
-USE: combinators
-USE: errors
-USE: kernel
-USE: stack
-USE: vectors
-USE: words
-
-DEFER: number=
-
-: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
-: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
-
-: reduce ( x y -- x' y' )
- dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
-: ratio ( x y -- x/y ) reduce fraction> ;
-: >fraction ( a/b -- a b ) dup numerator swap denominator ;
-: 2>fraction ( a/b c/d -- a c b d )
- [ swap numerator swap numerator ] 2keep
- swap denominator swap denominator ;
-
-: ratio= ( a/b c/d -- ? )
- 2>fraction number= [ number= ] [ 2drop f ] ifte ;
-: ratio-scale ( a/b c/d -- a*d b*c )
- 2>fraction >r * swap r> * swap ;
-: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
-: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
-: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
-: ratio* ( x y -- x*y ) 2>fraction * >r * r> ratio ;
-: ratio/ ( x y -- x/y ) ratio-scale ratio ;
-: ratio/f ( x y -- x/y ) ratio-scale /f ;
-
-: ratio< ( x y -- ? ) ratio-scale < ;
-: ratio<= ( x y -- ? ) ratio-scale <= ;
-: ratio> ( x y -- ? ) ratio-scale > ;
-: ratio>= ( x y -- ? ) ratio-scale >= ;
-
-: >rect ( x -- x:re x: im ) dup real swap imaginary ;
-: 2>rect ( x y -- x:re y:re x:im y:im )
- [ swap real swap real ] 2keep
- swap imaginary swap imaginary ;
-
-: complex= ( x y -- ? )
- 2>rect number= [ number= ] [ 2drop f ] ifte ;
-
-: complex+ ( x y -- x+y ) 2>rect + >r + r> rect> ;
-: complex- ( x y -- x-y ) 2>rect - >r - r> rect> ;
-: complex*re ( x y -- x:re * y:re x:im * r:im )
- 2>rect * >r * r> ;
-: complex*im ( x y -- x:im * y:re x:re * y:im )
- 2>rect >r * swap r> * ;
-: complex* ( x y -- x*y )
- 2dup complex*re - -rot complex*im + rect> ;
-: abs^2 ( x -- y ) >rect sq swap sq + ;
-: (complex/) ( x y -- r i m )
- #! r = x:re * y:re + x:im * y:im
- #! i = x:im * y:re - x:re * y:im
- #! m = y:re * y:re + y:im * y:im
- dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
-: complex/ ( x y -- x/y )
- (complex/) tuck / >r / r> rect> ;
-: complex/f ( x y -- x/y )
- (complex/) tuck /f >r /f r> rect> ;
-
-: no-method ( -- )
- "No applicable method" throw ;
-
-: (not-=) ( x y -- f )
- 2drop f ;
-
-: number= ( x y -- ? )
- {
- fixnum=
- (not-=)
- (not-=)
- (not-=)
- ratio=
- complex=
- (not-=)
- (not-=)
- (not-=)
- bignum=
- float=
- (not-=)
- (not-=)
- (not-=)
- (not-=)
- (not-=)
- (not-=)
- } 2generic ;
-
-: + ( x y -- x+y )
- {
- fixnum+
- no-method
- no-method
- no-method
- ratio+
- complex+
- no-method
- no-method
- no-method
- bignum+
- float+
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: - ( x y -- x-y )
- {
- fixnum-
- no-method
- no-method
- no-method
- ratio-
- complex-
- no-method
- no-method
- no-method
- bignum-
- float-
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: * ( x y -- x*y )
- {
- fixnum*
- no-method
- no-method
- no-method
- ratio*
- complex*
- no-method
- no-method
- no-method
- bignum*
- float*
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: / ( x y -- x/y )
- {
- ratio
- no-method
- no-method
- no-method
- ratio/
- complex/
- no-method
- no-method
- no-method
- ratio
- float/f
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: /i ( x y -- x/y )
- {
- fixnum/i
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum/i
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: /f ( x y -- x/y )
- {
- fixnum/f
- no-method
- no-method
- no-method
- ratio/f
- complex/f
- no-method
- no-method
- no-method
- bignum/f
- float/f
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: mod ( x y -- x%y )
- {
- fixnum-mod
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-mod
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: /mod ( x y -- x/y x%y )
- {
- fixnum/mod
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum/mod
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: bitand ( x y -- x&y )
- {
- fixnum-bitand
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-bitand
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: bitor ( x y -- x|y )
- {
- fixnum-bitor
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-bitor
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: bitxor ( x y -- x^y )
- {
- fixnum-bitxor
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-bitxor
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: bitnot ( x -- ~x )
- {
- fixnum-bitnot
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-bitnot
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } generic ;
-
-: shift ( x n -- x<<n )
- {
- fixnum-shift
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- bignum-shift
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: < ( x y -- ? )
- {
- fixnum<
- no-method
- no-method
- no-method
- ratio<
- no-method
- no-method
- no-method
- no-method
- bignum<
- float<
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: <= ( x y -- ? )
- {
- fixnum<=
- no-method
- no-method
- no-method
- ratio<=
- no-method
- no-method
- no-method
- no-method
- bignum<=
- float<=
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: > ( x y -- ? )
- {
- fixnum>
- no-method
- no-method
- no-method
- ratio>
- no-method
- no-method
- no-method
- no-method
- bignum>
- float>
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
-
-: >= ( x y -- ? )
- {
- fixnum>=
- no-method
- no-method
- no-method
- ratio>=
- no-method
- no-method
- no-method
- no-method
- bignum>=
- float>=
- no-method
- no-method
- no-method
- no-method
- no-method
- no-method
- } 2generic ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: namespaces
-USE: combinators
-USE: hashtables
-USE: kernel
-USE: lists
-USE: math
-USE: stack
-USE: strings
-USE: vectors
-
-DEFER: namespace
-
-: namestack ( -- ns ) 3 getenv ;
-: set-namestack ( ns -- ) 3 setenv ;
-
-: >n ( namespace -- n:namespace )
- #! Push a namespace on the namespace stack.
- namestack cons set-namestack ; inline
-
-: n> ( n:namespace -- namespace )
- #! Pop the top of the namespace stack.
- namestack uncons set-namestack ; inline
-
-: global ( -- g ) 4 getenv ;
-: set-global ( g -- ) 4 setenv ;
-
-: init-namespaces ( -- )
- global >n global "global" set ;
-
-: namespace-buckets 23 ;
-
-: <namespace> ( -- n )
- #! Create a new namespace.
- namespace-buckets <hashtable> ;
-
-: (get) ( var ns -- value )
- #! Internal word for searching the namestack.
- dup [
- 2dup car hash* dup [
- nip nip cdr ( found )
- ] [
- drop cdr (get) ( keep looking )
- ] ifte
- ] [
- 2drop f
- ] ifte ;
-
-: get ( variable -- value )
- #! Push the value of a variable by searching the namestack
- #! from the top down.
- namestack (get) ;
-
-: set ( value variable -- ) namespace set-hash ;
-: put ( variable value -- ) swap set ;
-
-: bind ( namespace quot -- )
- #! Execute a quotation with a namespace on the namestack.
- swap >n call n> drop ; inline
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: streams
-USE: combinators
-USE: continuations
-USE: io-internals
-USE: errors
-USE: hashtables
-USE: kernel
-USE: logic
-USE: stack
-USE: stdio
-USE: strings
-USE: namespaces
-USE: unparser
-
-: <server> ( port -- stream )
- #! Starts listening on localhost:port. Returns a stream that
- #! you can close with fclose, and accept connections from
- #! with accept. No other stream operations are supported.
- server-socket <stream> [
- "socket" set
-
- ( -- )
- [ "socket" get close-port ] "fclose" set
- ] extend ;
-
-: <client-stream> ( host port in out -- stream )
- <fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
-
-: <client> ( host port -- stream )
- #! fflush yields until connection is established.
- 2dup client-socket <client-stream> dup fflush ;
-
-: accept ( server -- client )
- #! Accept a connection from a server socket.
- "socket" swap hash blocking-accept <client-stream> ;
+++ /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: combinators
-USE: alien
-USE: compiler
-USE: errors
-USE: files
-USE: io-internals
-USE: kernel
-USE: lists
-USE: math
-USE: parser
-USE: profiler
-USE: random
-USE: real-math
-USE: stack
-USE: strings
-USE: unparser
-USE: vectors
-USE: words
-
-[
- [ execute " word -- " f ]
- [ call " quot -- " [ 1 | 0 ] ]
- [ ifte " cond true false -- " [ 3 | 0 ] ]
- [ cons " car cdr -- [ car | cdr ] " [ 2 | 1 ] ]
- [ car " [ car | cdr ] -- car " [ 1 | 1 ] ]
- [ cdr " [ car | cdr ] -- cdr " [ 1 | 1 ] ]
- [ <vector> " capacity -- vector" [ 1 | 1 ] ]
- [ vector-length " vector -- n " [ 1 | 1 ] ]
- [ set-vector-length " n vector -- " [ 2 | 0 ] ]
- [ vector-nth " n vector -- obj " [ 2 | 1 ] ]
- [ set-vector-nth " obj n vector -- " [ 3 | 0 ] ]
- [ str-length " str -- n " [ 1 | 1 ] ]
- [ str-nth " n str -- ch " [ 2 | 1 ] ]
- [ str-compare " str str -- -1/0/1 " [ 2 | 1 ] ]
- [ str= " str str -- ? " [ 2 | 1 ] ]
- [ str-hashcode " str -- n " [ 1 | 1 ] ]
- [ index-of* " n str/ch str -- n " [ 3 | 1 ] ]
- [ substring " start end str -- str " [ 3 | 1 ] ]
- [ str-reverse " str -- str " [ 1 | 1 ] ]
- [ <sbuf> " capacity -- sbuf " [ 1 | 1 ] ]
- [ sbuf-length " sbuf -- n " [ 1 | 1 ] ]
- [ set-sbuf-length " n sbuf -- " [ 2 | 1 ] ]
- [ sbuf-nth " n sbuf -- ch " [ 2 | 1 ] ]
- [ set-sbuf-nth " ch n sbuf -- " [ 3 | 0 ] ]
- [ sbuf-append " ch/str sbuf -- " [ 2 | 1 ] ]
- [ sbuf>str " sbuf -- str " [ 1 | 1 ] ]
- [ sbuf-reverse " sbuf -- " [ 1 | 0 ] ]
- [ sbuf-clone " sbuf -- sbuf " [ 1 | 1 ] ]
- [ sbuf= " sbuf sbuf -- ? " [ 2 | 1 ] ]
- [ sbuf-hashcode " sbuf -- n " [ 1 | 1 ] ]
- [ arithmetic-type " n n -- type " [ 2 | 1 ] ]
- [ number? " obj -- ? " [ 1 | 1 ] ]
- [ >fixnum " n -- fixnum " [ 1 | 1 ] ]
- [ >bignum " n -- bignum " [ 1 | 1 ] ]
- [ >float " n -- float " [ 1 | 1 ] ]
- [ numerator " a/b -- a " [ 1 | 1 ] ]
- [ denominator " a/b -- b " [ 1 | 1 ] ]
- [ fraction> " a b -- a/b " [ 1 | 1 ] ]
- [ str>float " str -- float " [ 1 | 1 ] ]
- [ unparse-float " float -- str " [ 1 | 1 ] ]
- [ float>bits " float -- n " [ 1 | 1 ] ]
- [ real " #{ re im } -- re " [ 1 | 1 ] ]
- [ imaginary " #{ re im } -- im " [ 1 | 1 ] ]
- [ rect> " re im -- #{ re im } " [ 2 | 1 ] ]
- [ fixnum= " x y -- ? " [ 2 | 1 ] ]
- [ fixnum+ " x y -- x+y " [ 2 | 1 ] ]
- [ fixnum- " x y -- x-y " [ 2 | 1 ] ]
- [ fixnum* " x y -- x*y " [ 2 | 1 ] ]
- [ fixnum/i " x y -- x/y " [ 2 | 1 ] ]
- [ fixnum/f " x y -- x/y " [ 2 | 1 ] ]
- [ fixnum-mod " x y -- x%y " [ 2 | 1 ] ]
- [ fixnum/mod " x y -- x/y x%y " [ 2 | 2 ] ]
- [ fixnum-bitand " x y -- x&y " [ 2 | 1 ] ]
- [ fixnum-bitor " x y -- x|y " [ 2 | 1 ] ]
- [ fixnum-bitxor " x y -- x^y " [ 2 | 1 ] ]
- [ fixnum-bitnot " x -- ~x " [ 1 | 1 ] ]
- [ fixnum-shift " x n -- x<<n" [ 2 | 1 ] ]
- [ fixnum< " x y -- ? " [ 2 | 1 ] ]
- [ fixnum<= " x y -- ? " [ 2 | 1 ] ]
- [ fixnum> " x y -- ? " [ 2 | 1 ] ]
- [ fixnum>= " x y -- ? " [ 2 | 1 ] ]
- [ bignum= " x y -- ? " [ 2 | 1 ] ]
- [ bignum+ " x y -- x+y " [ 2 | 1 ] ]
- [ bignum- " x y -- x-y " [ 2 | 1 ] ]
- [ bignum* " x y -- x*y " [ 2 | 1 ] ]
- [ bignum/i " x y -- x/y " [ 2 | 1 ] ]
- [ bignum/f " x y -- x/y " [ 2 | 1 ] ]
- [ bignum-mod " x y -- x%y " [ 2 | 1 ] ]
- [ bignum/mod " x y -- x/y x%y " [ 2 | 2 ] ]
- [ bignum-bitand " x y -- x&y " [ 2 | 1 ] ]
- [ bignum-bitor " x y -- x|y " [ 2 | 1 ] ]
- [ bignum-bitxor " x y -- x^y " [ 2 | 1 ] ]
- [ bignum-bitnot " x -- ~x " [ 1 | 1 ] ]
- [ bignum-shift " x n -- x<<n" [ 2 | 1 ] ]
- [ bignum< " x y -- ? " [ 2 | 1 ] ]
- [ bignum<= " x y -- ? " [ 2 | 1 ] ]
- [ bignum> " x y -- ? " [ 2 | 1 ] ]
- [ bignum>= " x y -- ? " [ 2 | 1 ] ]
- [ float= " x y -- ? " [ 2 | 1 ] ]
- [ float+ " x y -- x+y " [ 2 | 1 ] ]
- [ float- " x y -- x-y " [ 2 | 1 ] ]
- [ float* " x y -- x*y " [ 2 | 1 ] ]
- [ float/f " x y -- x/y " [ 2 | 1 ] ]
- [ float< " x y -- ? " [ 2 | 1 ] ]
- [ float<= " x y -- ? " [ 2 | 1 ] ]
- [ float> " x y -- ? " [ 2 | 1 ] ]
- [ float>= " x y -- ? " [ 2 | 1 ] ]
- [ facos " x -- y " [ 1 | 1 ] ]
- [ fasin " x -- y " [ 1 | 1 ] ]
- [ fatan " x -- y " [ 1 | 1 ] ]
- [ fatan2 " x y -- z " [ 2 | 1 ] ]
- [ fcos " x -- y " [ 1 | 1 ] ]
- [ fexp " x -- y " [ 1 | 1 ] ]
- [ fcosh " x -- y " [ 1 | 1 ] ]
- [ flog " x -- y " [ 1 | 1 ] ]
- [ fpow " x y -- z " [ 2 | 1 ] ]
- [ fsin " x -- y " [ 1 | 1 ] ]
- [ fsinh " x -- y " [ 1 | 1 ] ]
- [ fsqrt " x -- y " [ 1 | 1 ] ]
- [ <word> " prim param plist -- word " [ 3 | 1 ] ]
- [ word-hashcode " word -- n " [ 1 | 1 ] ]
- [ word-xt " word -- xt " [ 1 | 1 ] ]
- [ set-word-xt " xt word -- " [ 2 | 0 ] ]
- [ word-primitive " word -- n " [ 1 | 1 ] ]
- [ set-word-primitive " n word -- " [ 2 | 0 ] ]
- [ word-parameter " word -- obj " [ 1 | 1 ] ]
- [ set-word-parameter " obj word -- " [ 2 | 0 ] ]
- [ word-plist " word -- alist" [ 1 | 1 ] ]
- [ set-word-plist " alist word -- " [ 2 | 0 ] ]
- [ drop " x -- " [ 1 | 0 ] ]
- [ dup " x -- x x " [ 1 | 2 ] ]
- [ swap " x y -- y x " [ 2 | 2 ] ]
- [ over " x y -- x y x " [ 2 | 3 ] ]
- [ pick " x y z -- x y z x " [ 3 | 4 ] ]
- [ nip " x y -- y " [ 2 | 1 ] ]
- [ tuck " x y -- y x y " [ 2 | 3 ] ]
- [ rot " x y z -- y z x " [ 3 | 3 ] ]
- [ >r " x -- r:x " [ 1 | 0 ] ]
- [ r> " r:x -- x " [ 0 | 1 ] ]
- [ eq? " x y -- ? " [ 2 | 1 ] ]
- [ getenv " n -- obj " [ 1 | 1 ] ]
- [ setenv " obj n -- " [ 2 | 0 ] ]
- [ open-file " path r w -- port " [ 3 | 1 ] ]
- [ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ]
- [ (directory) " path -- list " [ 1 | 1 ] ]
- [ garbage-collection " -- " [ 0 | 0 ] ]
- [ save-image " path -- " [ 1 | 0 ] ]
- [ datastack " -- ds " f ]
- [ callstack " -- cs " f ]
- [ set-datastack " ds -- " f ]
- [ set-callstack " cs -- " f ]
- [ exit* " n -- " [ 1 | 0 ] ]
- [ client-socket " host port -- in out " [ 2 | 2 ] ]
- [ server-socket " port -- server " [ 1 | 1 ] ]
- [ close-port " port -- " [ 1 | 0 ] ]
- [ add-accept-io-task " server callback -- " [ 2 | 0 ] ]
- [ accept-fd " server -- host port in out " [ 1 | 4 ] ]
- [ can-read-line? " port -- ? " [ 1 | 1 ] ]
- [ add-read-line-io-task " port callback -- " [ 2 | 0 ] ]
- [ read-line-fd-8 " port -- sbuf " [ 1 | 1 ] ]
- [ can-read-count? " n port -- ? " [ 2 | 1 ] ]
- [ add-read-count-io-task " n port callback -- " [ 3 | 0 ] ]
- [ read-count-fd-8 " n port -- sbuf " [ 2 | 1 ] ]
- [ can-write? " n port -- ? " [ 2 | 1 ] ]
- [ add-write-io-task " port callback -- " [ 2 | 0 ] ]
- [ write-fd-8 " ch/str port -- " [ 2 | 0 ] ]
- [ add-copy-io-task " from to callback -- " [ 3 | 1 ] ]
- [ pending-io-error " -- " [ 0 | 0 ] ]
- [ next-io-task " -- callback " [ 0 | 1 ] ]
- [ room " -- free total free total " [ 0 | 4 ] ]
- [ os-env " str -- str " [ 1 | 1 ] ]
- [ millis " -- n " [ 0 | 1 ] ]
- [ init-random " -- " [ 0 | 0 ] ]
- [ (random-int) " -- n " [ 0 | 1 ] ]
- [ type " obj -- n " [ 1 | 1 ] ]
- [ size " obj -- n " [ 1 | 1 ] ]
- [ call-profiling " depth -- " [ 1 | 0 ] ]
- [ call-count " word -- n " [ 1 | 1 ] ]
- [ set-call-count " n word -- " [ 2 | 0 ] ]
- [ allot-profiling " depth -- " [ 1 | 0 ] ]
- [ allot-count " word -- n " [ 1 | 1 ] ]
- [ set-allot-count " n word -- n " [ 2 | 1 ] ]
- [ cwd " -- dir " [ 0 | 1 ] ]
- [ cd " dir -- " [ 1 | 0 ] ]
- [ compiled-offset " -- ptr " [ 0 | 1 ] ]
- [ set-compiled-offset " ptr -- " [ 1 | 0 ] ]
- [ set-compiled-cell " n ptr -- " [ 2 | 0 ] ]
- [ set-compiled-byte " n ptr -- " [ 2 | 0 ] ]
- [ literal-top " -- ptr " [ 0 | 1 ] ]
- [ set-literal-top " ptr -- " [ 1 | 0 ] ]
- [ address " obj -- ptr " [ 1 | 1 ] ]
- [ dlopen " path -- dll " [ 1 | 1 ] ]
- [ dlsym " name dll -- ptr " [ 2 | 1 ] ]
- [ dlsym-self " name -- ptr " [ 1 | 1 ] ]
- [ dlclose " dll -- " [ 1 | 0 ] ]
- [ <alien> " ptr -- alien " [ 1 | 1 ] ]
- [ <local-alien> " len -- alien " [ 1 | 1 ] ]
- [ alien-cell " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-cell " n alien off -- " [ 3 | 0 ] ]
- [ alien-4 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-4 " n alien off -- " [ 3 | 0 ] ]
- [ alien-2 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-2 " n alien off -- " [ 3 | 0 ] ]
- [ alien-1 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-1 " n alien off -- " [ 3 | 0 ] ]
- [ heap-stats " -- instances bytes " [ 0 | 2 ] ]
- [ throw " error -- " [ 1 | 0 ] ]
-] [
- uncons dupd uncons car ( word word stack-effect infer-effect )
- >r "stack-effect" set-word-property r>
- "infer-effect" set-word-property
-] each
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: profiler
-USE: combinators
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: words
-USE: vectors
-
-! The variable "only-top" toggles between
-! culminative counts, and top of call stack counts.
-SYMBOL: only-top
-
-: reset-counts ( -- )
- [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
-
-: sort-counts ( alist -- alist )
- [ swap cdr swap cdr > ] sort ;
-
-: call-count, ( word -- )
- #! Add to constructing list if call count is non-zero.
- dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-
-: counts. ( alist -- )
- sort-counts [ . ] each ;
-
-: call-counts. ( -- )
- #! Print word/call count pairs.
- [ [ call-count, ] each-word ] make-list counts. ;
-
-: profile-depth ( -- n )
- only-top get [ -1 ] [ callstack vector-length ] ifte ;
-
-: (call-profile) ( quot -- )
- reset-counts
- profile-depth call-profiling
- call
- f call-profiling ;
-
-: call-profile ( quot -- )
- #! Execute a quotation with the CPU profiler enabled.
- (call-profile) call-counts. ;
-
-: allot-count, ( word -- )
- #! Add to constructing list if allot count is non-zero.
- dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
-
-: allot-counts. ( -- alist )
- #! Print word/allot count pairs.
- [ [ allot-count, ] each-word ] make-list counts. ;
-
-: allot-profile ( quot -- )
- #! Execute a quotation with the memory profiler enabled.
- reset-counts
- profile-depth allot-profiling
- call
- f allot-profiling
- allot-counts. ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: random
-USE: combinators
-USE: kernel
-USE: math
-USE: stack
-
-: power-of-2? ( n -- ? )
- dup dup neg bitand = ;
-
-: (random-int-0) ( n bits val -- n )
- 3dup - + pred 0 < [
- 2drop (random-int) 2dup swap mod (random-int-0)
- ] [
- nip nip
- ] ifte ;
-
-: random-int-0 ( max -- n )
- succ dup power-of-2? [
- (random-int) * -31 shift
- ] [
- (random-int) 2dup swap mod (random-int-0)
- ] ifte ;
-
-: random-int ( min max -- n )
- dupd swap - random-int-0 + ;
-
-: random-boolean ( -- ? )
- 0 1 random-int 0 = ;
-
-! TODO: : random-float ... ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: stack
-USE: vectors
-
-: nop ( -- ) ;
-: 2drop ( x x -- ) drop drop ;
-: 3drop ( x x x -- ) drop drop drop ;
-: 2dup ( x y -- x y x y ) over over ;
-: 3dup ( x y z -- x y z x y z ) pick pick pick ;
-: -rot ( x y z -- z x y ) rot rot ;
-: dupd ( x y -- x x y ) >r dup r> ;
-: swapd ( x y z -- y x z ) >r swap r> ;
-: transp ( x y z -- z y x ) swap rot ;
-: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ;
-
-: clear ( -- )
- #! Clear the datastack. For interactive use only; invoking
- #! this from a word definition will clobber any values left
- #! on the data stack by the caller.
- { } set-datastack ;
-
-: depth ( -- n )
- #! Push the number of elements on the datastack.
- datastack vector-length ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: streams
-USE: combinators
-USE: continuations
-USE: io-internals
-USE: errors
-USE: hashtables
-USE: kernel
-USE: logic
-USE: stack
-USE: stdio
-USE: strings
-USE: namespaces
-
-: <fd-stream> ( in out -- stream )
- #! Create a file descriptor stream object, wrapping a pair
- #! of file descriptor handles for input and output.
- <stream> [
- "out" set
- "in" set
-
- ( str -- )
- [ "out" get blocking-write ] "fwrite" set
-
- ( -- str )
- [ "in" get dup [ blocking-read-line ] when ] "freadln" set
-
- ( count -- str )
- [
- "in" get dup [ blocking-read# ] [ nip ] ifte
- ] "fread#" set
-
- ( -- )
- [ "out" get [ blocking-flush ] when* ] "fflush" set
-
- ( -- )
- [
- "out" get [ dup blocking-flush close-port ] when*
- "in" get [ close-port ] when*
- ] "fclose" set
- ] extend ;
-
-: <filecr> ( path -- stream )
- t f open-file <fd-stream> ;
-
-: <filecw> ( path -- stream )
- f t open-file <fd-stream> ;
-
-: <filebr> ( path -- stream )
- <filecr> ;
-
-: <filebw> ( path -- stream )
- <filecw> ;
-
-: init-stdio ( -- )
- stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
-
-: (fcopy) ( from to -- )
- #! Copy the contents of the fd-stream 'from' to the
- #! fd-stream 'to'. Use fcopy; this word does not close
- #! streams.
- "out" swap hash >r "in" swap hash r> blocking-copy ;
-
-: fcopy ( from to -- )
- #! Copy the contents of the fd-stream 'from' to the
- #! fd-stream 'to'.
- [ 2dup (fcopy) ] [ -rot fclose fclose rethrow ] catch ;
-
-: resource-path ( -- path )
- "resource-path" get [ "." ] unless* ;
-
-: <resource-stream> ( path -- stream )
- resource-path swap cat2 <filecr> ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: strings
-USE: kernel
-USE: logic
-USE: math
-USE: stack
-
-: cat2 ( "a" "b" -- "ab" )
- swap
- 80 <sbuf>
- dup >r sbuf-append r>
- dup >r sbuf-append r>
- sbuf>str ;
-
-! HACKS
-: char? drop f ;
-: >char ;
-: >upper ;
-: >lower ;
+++ /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: threads
-USE: combinators
-USE: continuations
-USE: io-internals
-USE: kernel
-USE: lists
-USE: stack
-
-! Core of the multitasker. Used by io-internals.factor and
-! in-thread.factor.
-
-: run-queue ( -- queue )
- 9 getenv ;
-
-: set-run-queue ( queue -- )
- 9 setenv ;
-
-: init-threads ( -- )
- f set-run-queue ;
-
-: next-thread ( -- quot )
- #! Get and remove the next quotation from the run queue.
- run-queue dup [ uncons set-run-queue ] when ;
-
-: schedule-thread ( quot -- )
- #! Add a quotation to the run queue.
- run-queue cons set-run-queue ;
-
-: (yield) ( -- )
- #! If there is a quotation in the run queue, call it,
- #! otherwise wait for I/O. The currently executing
- #! continuation is suspended. Use yield instead.
- next-thread [
- call
- ] [
- next-io-task [
- call
- ] [
- (yield)
- ] ifte*
- ] ifte* ;
-
-: yield ( -- )
- #! Add the current continuation to the run queue, and yield
- #! to the next quotation. The current continuation will
- #! eventually be restored by a future call to (yield) or
- #! yield.
- [ schedule-thread (yield) ] callcc0 ;
+++ /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
-
-IN: math : fixnum? ( obj -- ? ) type 0 eq? ;
-IN: words : word? ( obj -- ? ) type 1 eq? ;
-IN: lists : cons? ( obj -- ? ) type 2 eq? ;
-IN: math : ratio? ( obj -- ? ) type 4 eq? ;
-IN: math : complex? ( obj -- ? ) type 5 eq? ;
-IN: math : bignum? ( obj -- ? ) type 9 eq? ;
-IN: math : float? ( obj -- ? ) type 10 eq? ;
-IN: vectors : vector? ( obj -- ? ) type 11 eq? ;
-IN: strings : string? ( obj -- ? ) type 12 eq? ;
-IN: strings : sbuf? ( obj -- ? ) type 13 eq? ;
-IN: io-internals : port? ( obj -- ? ) type 14 eq? ;
-IN: alien : dll? ( obj -- ? ) type 15 eq? ;
-IN: alien : alien? ( obj -- ? ) type 16 eq? ;
-
-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 ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: vectors
-USE: combinators
-USE: kernel
-USE: lists
-USE: math
-USE: stack
-
-: ?vector= ( n vec vec -- ? )
- #! Reached end?
- drop vector-length = ;
-
-: (vector=) ( n vec vec -- ? )
- 3dup ?vector= [
- 3drop t ( reached end without any unequal elts )
- ] [
- 3dup 2vector-nth = [
- >r >r succ r> r> (vector=)
- ] [
- 3drop f
- ] ifte
- ] ifte ;
-
-: vector-length= ( vec vec -- ? )
- vector-length swap vector-length number= ;
-
-: vector= ( obj vec -- ? )
- #! Check if two vectors are equal. Two vectors are
- #! considered equal if they have the same length and contain
- #! equal elements.
- 2dup eq? [
- 2drop t
- ] [
- over vector? [
- 2dup vector-length= [
- 0 -rot (vector=)
- ] [
- 2drop f
- ] ifte
- ] [
- 2drop f
- ] ifte
- ] ifte ;
-
-: ?vector-nth ( n vec -- obj/f )
- 2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ;
-
-: vector-hashcode ( vec -- n )
- 0 swap 4 [
- over ?vector-nth hashcode rot bitxor swap
- ] times* drop ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: words
-USE: combinators
-USE: hashtables
-USE: lists
-USE: namespaces
-USE: stack
-
-: (search) ( name vocab -- word )
- vocab dup [ hash ] [ 2drop f ] ifte ;
-
-: search ( name list -- word )
- #! Search for a word in a list of vocabularies.
- dup [
- 2dup car (search) dup [
- nip nip ( found )
- ] [
- drop cdr search ( check next )
- ] ifte
- ] [
- 2drop f ( not found )
- ] ifte ;
-
-: <plist> ( name vocab -- plist )
- "vocabulary" swons swap "name" swons 2list ;
-
-: (create) ( name vocab -- word )
- #! Create an undefined word without adding to a vocabulary.
- <plist> 0 f rot <word> ;
-
-: reveal ( word -- )
- #! Add a new word to its vocabulary.
- global [
- "vocabularies" get [
- dup word-vocabulary
- over word-name
- 2list set-object-path
- ] bind
- ] bind ;
-
-: create ( name vocab -- word )
- #! Create a new word in a vocabulary. If the vocabulary
- #! already contains the word, the existing instance is
- #! returned.
- 2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: words
-USE: combinators
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-
-: word-property ( word pname -- pvalue )
- swap word-plist assoc ;
-
-: set-word-property ( word pvalue pname -- )
- pick word-plist
- pick [ set-assoc ] [ remove-assoc nip ] ifte
- swap set-word-plist ;
-
-: ?word-primitive ( obj -- prim/0 )
- dup word? [ word-primitive ] [ drop 0 ] ifte ;
-
-: defined? ( obj -- ? ) ?word-primitive 0 = not ;
-: compound? ( obj -- ? ) ?word-primitive 1 = ;
-: primitive? ( obj -- ? ) ?word-primitive 2 > ;
-: symbol? ( obj -- ? ) ?word-primitive 2 = ;
-
-: word ( -- word ) global [ "last-word" get ] bind ;
-: set-word ( word -- ) global [ "last-word" set ] bind ;
-
-: define-compound ( word def -- )
- over set-word-parameter
- 1 over set-word-primitive
- f "parsing" set-word-property ;
-
-: define-symbol ( word -- )
- dup dup set-word-parameter
- 2 swap set-word-primitive ;
-
-: stack-effect ( word -- str ) "stack-effect" word-property ;
-: documentation ( word -- str ) "documentation" word-property ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: presentation
-USE: combinators
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: stack
-USE: strings
-USE: unparser
-
-: <actions> ( path alist -- alist )
- #! For each element of the alist, change the value to
- #! path " " value
- >r unparse r>
- [ uncons >r over " " r> cat3 cons ] map nip ;
-
-! A style is an alist whose key/value pairs hold
-! significance to the 'fwrite-attr' word when applied to a
-! stream that supports attributed string output.
-
-: (style) ( name -- style ) "styles" get hash ;
-: default-style ( -- style ) "default" (style) ;
-: style ( name -- style ) (style) [ default-style ] unless* ;
-: set-style ( style name -- ) "styles" get set-hash ;
-
-<namespace> "styles" set
-
-[
- [ "font" | "Monospaced" ]
-] "default" set-style
-
-[
- [ "bold" | t ]
-] default-style append "prompt" set-style
-
-[
- [ "ansi-fg" | "0" ]
- [ "ansi-bg" | "2" ]
- [ "fg" | [ 255 0 0 ] ]
-] default-style append "comments" set-style
--- /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: combinators
+USE: alien
+USE: compiler
+USE: errors
+USE: files
+USE: io-internals
+USE: kernel
+USE: lists
+USE: math
+USE: parser
+USE: profiler
+USE: random
+USE: real-math
+USE: stack
+USE: strings
+USE: unparser
+USE: vectors
+USE: words
+
+[
+ [ execute " word -- " f ]
+ [ call " quot -- " [ 1 | 0 ] ]
+ [ ifte " cond true false -- " [ 3 | 0 ] ]
+ [ cons " car cdr -- [ car | cdr ] " [ 2 | 1 ] ]
+ [ car " [ car | cdr ] -- car " [ 1 | 1 ] ]
+ [ cdr " [ car | cdr ] -- cdr " [ 1 | 1 ] ]
+ [ <vector> " capacity -- vector" [ 1 | 1 ] ]
+ [ vector-length " vector -- n " [ 1 | 1 ] ]
+ [ set-vector-length " n vector -- " [ 2 | 0 ] ]
+ [ vector-nth " n vector -- obj " [ 2 | 1 ] ]
+ [ set-vector-nth " obj n vector -- " [ 3 | 0 ] ]
+ [ str-length " str -- n " [ 1 | 1 ] ]
+ [ str-nth " n str -- ch " [ 2 | 1 ] ]
+ [ str-compare " str str -- -1/0/1 " [ 2 | 1 ] ]
+ [ str= " str str -- ? " [ 2 | 1 ] ]
+ [ str-hashcode " str -- n " [ 1 | 1 ] ]
+ [ index-of* " n str/ch str -- n " [ 3 | 1 ] ]
+ [ substring " start end str -- str " [ 3 | 1 ] ]
+ [ str-reverse " str -- str " [ 1 | 1 ] ]
+ [ <sbuf> " capacity -- sbuf " [ 1 | 1 ] ]
+ [ sbuf-length " sbuf -- n " [ 1 | 1 ] ]
+ [ set-sbuf-length " n sbuf -- " [ 2 | 1 ] ]
+ [ sbuf-nth " n sbuf -- ch " [ 2 | 1 ] ]
+ [ set-sbuf-nth " ch n sbuf -- " [ 3 | 0 ] ]
+ [ sbuf-append " ch/str sbuf -- " [ 2 | 1 ] ]
+ [ sbuf>str " sbuf -- str " [ 1 | 1 ] ]
+ [ sbuf-reverse " sbuf -- " [ 1 | 0 ] ]
+ [ sbuf-clone " sbuf -- sbuf " [ 1 | 1 ] ]
+ [ sbuf= " sbuf sbuf -- ? " [ 2 | 1 ] ]
+ [ sbuf-hashcode " sbuf -- n " [ 1 | 1 ] ]
+ [ arithmetic-type " n n -- type " [ 2 | 1 ] ]
+ [ number? " obj -- ? " [ 1 | 1 ] ]
+ [ >fixnum " n -- fixnum " [ 1 | 1 ] ]
+ [ >bignum " n -- bignum " [ 1 | 1 ] ]
+ [ >float " n -- float " [ 1 | 1 ] ]
+ [ numerator " a/b -- a " [ 1 | 1 ] ]
+ [ denominator " a/b -- b " [ 1 | 1 ] ]
+ [ fraction> " a b -- a/b " [ 1 | 1 ] ]
+ [ str>float " str -- float " [ 1 | 1 ] ]
+ [ unparse-float " float -- str " [ 1 | 1 ] ]
+ [ float>bits " float -- n " [ 1 | 1 ] ]
+ [ real " #{ re im } -- re " [ 1 | 1 ] ]
+ [ imaginary " #{ re im } -- im " [ 1 | 1 ] ]
+ [ rect> " re im -- #{ re im } " [ 2 | 1 ] ]
+ [ fixnum= " x y -- ? " [ 2 | 1 ] ]
+ [ fixnum+ " x y -- x+y " [ 2 | 1 ] ]
+ [ fixnum- " x y -- x-y " [ 2 | 1 ] ]
+ [ fixnum* " x y -- x*y " [ 2 | 1 ] ]
+ [ fixnum/i " x y -- x/y " [ 2 | 1 ] ]
+ [ fixnum/f " x y -- x/y " [ 2 | 1 ] ]
+ [ fixnum-mod " x y -- x%y " [ 2 | 1 ] ]
+ [ fixnum/mod " x y -- x/y x%y " [ 2 | 2 ] ]
+ [ fixnum-bitand " x y -- x&y " [ 2 | 1 ] ]
+ [ fixnum-bitor " x y -- x|y " [ 2 | 1 ] ]
+ [ fixnum-bitxor " x y -- x^y " [ 2 | 1 ] ]
+ [ fixnum-bitnot " x -- ~x " [ 1 | 1 ] ]
+ [ fixnum-shift " x n -- x<<n" [ 2 | 1 ] ]
+ [ fixnum< " x y -- ? " [ 2 | 1 ] ]
+ [ fixnum<= " x y -- ? " [ 2 | 1 ] ]
+ [ fixnum> " x y -- ? " [ 2 | 1 ] ]
+ [ fixnum>= " x y -- ? " [ 2 | 1 ] ]
+ [ bignum= " x y -- ? " [ 2 | 1 ] ]
+ [ bignum+ " x y -- x+y " [ 2 | 1 ] ]
+ [ bignum- " x y -- x-y " [ 2 | 1 ] ]
+ [ bignum* " x y -- x*y " [ 2 | 1 ] ]
+ [ bignum/i " x y -- x/y " [ 2 | 1 ] ]
+ [ bignum/f " x y -- x/y " [ 2 | 1 ] ]
+ [ bignum-mod " x y -- x%y " [ 2 | 1 ] ]
+ [ bignum/mod " x y -- x/y x%y " [ 2 | 2 ] ]
+ [ bignum-bitand " x y -- x&y " [ 2 | 1 ] ]
+ [ bignum-bitor " x y -- x|y " [ 2 | 1 ] ]
+ [ bignum-bitxor " x y -- x^y " [ 2 | 1 ] ]
+ [ bignum-bitnot " x -- ~x " [ 1 | 1 ] ]
+ [ bignum-shift " x n -- x<<n" [ 2 | 1 ] ]
+ [ bignum< " x y -- ? " [ 2 | 1 ] ]
+ [ bignum<= " x y -- ? " [ 2 | 1 ] ]
+ [ bignum> " x y -- ? " [ 2 | 1 ] ]
+ [ bignum>= " x y -- ? " [ 2 | 1 ] ]
+ [ float= " x y -- ? " [ 2 | 1 ] ]
+ [ float+ " x y -- x+y " [ 2 | 1 ] ]
+ [ float- " x y -- x-y " [ 2 | 1 ] ]
+ [ float* " x y -- x*y " [ 2 | 1 ] ]
+ [ float/f " x y -- x/y " [ 2 | 1 ] ]
+ [ float< " x y -- ? " [ 2 | 1 ] ]
+ [ float<= " x y -- ? " [ 2 | 1 ] ]
+ [ float> " x y -- ? " [ 2 | 1 ] ]
+ [ float>= " x y -- ? " [ 2 | 1 ] ]
+ [ facos " x -- y " [ 1 | 1 ] ]
+ [ fasin " x -- y " [ 1 | 1 ] ]
+ [ fatan " x -- y " [ 1 | 1 ] ]
+ [ fatan2 " x y -- z " [ 2 | 1 ] ]
+ [ fcos " x -- y " [ 1 | 1 ] ]
+ [ fexp " x -- y " [ 1 | 1 ] ]
+ [ fcosh " x -- y " [ 1 | 1 ] ]
+ [ flog " x -- y " [ 1 | 1 ] ]
+ [ fpow " x y -- z " [ 2 | 1 ] ]
+ [ fsin " x -- y " [ 1 | 1 ] ]
+ [ fsinh " x -- y " [ 1 | 1 ] ]
+ [ fsqrt " x -- y " [ 1 | 1 ] ]
+ [ <word> " prim param plist -- word " [ 3 | 1 ] ]
+ [ word-hashcode " word -- n " [ 1 | 1 ] ]
+ [ word-xt " word -- xt " [ 1 | 1 ] ]
+ [ set-word-xt " xt word -- " [ 2 | 0 ] ]
+ [ word-primitive " word -- n " [ 1 | 1 ] ]
+ [ set-word-primitive " n word -- " [ 2 | 0 ] ]
+ [ word-parameter " word -- obj " [ 1 | 1 ] ]
+ [ set-word-parameter " obj word -- " [ 2 | 0 ] ]
+ [ word-plist " word -- alist" [ 1 | 1 ] ]
+ [ set-word-plist " alist word -- " [ 2 | 0 ] ]
+ [ drop " x -- " [ 1 | 0 ] ]
+ [ dup " x -- x x " [ 1 | 2 ] ]
+ [ swap " x y -- y x " [ 2 | 2 ] ]
+ [ over " x y -- x y x " [ 2 | 3 ] ]
+ [ pick " x y z -- x y z x " [ 3 | 4 ] ]
+ [ nip " x y -- y " [ 2 | 1 ] ]
+ [ tuck " x y -- y x y " [ 2 | 3 ] ]
+ [ rot " x y z -- y z x " [ 3 | 3 ] ]
+ [ >r " x -- r:x " [ 1 | 0 ] ]
+ [ r> " r:x -- x " [ 0 | 1 ] ]
+ [ eq? " x y -- ? " [ 2 | 1 ] ]
+ [ getenv " n -- obj " [ 1 | 1 ] ]
+ [ setenv " obj n -- " [ 2 | 0 ] ]
+ [ open-file " path r w -- port " [ 3 | 1 ] ]
+ [ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ]
+ [ (directory) " path -- list " [ 1 | 1 ] ]
+ [ garbage-collection " -- " [ 0 | 0 ] ]
+ [ save-image " path -- " [ 1 | 0 ] ]
+ [ datastack " -- ds " f ]
+ [ callstack " -- cs " f ]
+ [ set-datastack " ds -- " f ]
+ [ set-callstack " cs -- " f ]
+ [ exit* " n -- " [ 1 | 0 ] ]
+ [ client-socket " host port -- in out " [ 2 | 2 ] ]
+ [ server-socket " port -- server " [ 1 | 1 ] ]
+ [ close-port " port -- " [ 1 | 0 ] ]
+ [ add-accept-io-task " server callback -- " [ 2 | 0 ] ]
+ [ accept-fd " server -- host port in out " [ 1 | 4 ] ]
+ [ can-read-line? " port -- ? " [ 1 | 1 ] ]
+ [ add-read-line-io-task " port callback -- " [ 2 | 0 ] ]
+ [ read-line-fd-8 " port -- sbuf " [ 1 | 1 ] ]
+ [ can-read-count? " n port -- ? " [ 2 | 1 ] ]
+ [ add-read-count-io-task " n port callback -- " [ 3 | 0 ] ]
+ [ read-count-fd-8 " n port -- sbuf " [ 2 | 1 ] ]
+ [ can-write? " n port -- ? " [ 2 | 1 ] ]
+ [ add-write-io-task " port callback -- " [ 2 | 0 ] ]
+ [ write-fd-8 " ch/str port -- " [ 2 | 0 ] ]
+ [ add-copy-io-task " from to callback -- " [ 3 | 1 ] ]
+ [ pending-io-error " -- " [ 0 | 0 ] ]
+ [ next-io-task " -- callback " [ 0 | 1 ] ]
+ [ room " -- free total free total " [ 0 | 4 ] ]
+ [ os-env " str -- str " [ 1 | 1 ] ]
+ [ millis " -- n " [ 0 | 1 ] ]
+ [ init-random " -- " [ 0 | 0 ] ]
+ [ (random-int) " -- n " [ 0 | 1 ] ]
+ [ type " obj -- n " [ 1 | 1 ] ]
+ [ size " obj -- n " [ 1 | 1 ] ]
+ [ call-profiling " depth -- " [ 1 | 0 ] ]
+ [ call-count " word -- n " [ 1 | 1 ] ]
+ [ set-call-count " n word -- " [ 2 | 0 ] ]
+ [ allot-profiling " depth -- " [ 1 | 0 ] ]
+ [ allot-count " word -- n " [ 1 | 1 ] ]
+ [ set-allot-count " n word -- n " [ 2 | 1 ] ]
+ [ cwd " -- dir " [ 0 | 1 ] ]
+ [ cd " dir -- " [ 1 | 0 ] ]
+ [ compiled-offset " -- ptr " [ 0 | 1 ] ]
+ [ set-compiled-offset " ptr -- " [ 1 | 0 ] ]
+ [ set-compiled-cell " n ptr -- " [ 2 | 0 ] ]
+ [ set-compiled-byte " n ptr -- " [ 2 | 0 ] ]
+ [ literal-top " -- ptr " [ 0 | 1 ] ]
+ [ set-literal-top " ptr -- " [ 1 | 0 ] ]
+ [ address " obj -- ptr " [ 1 | 1 ] ]
+ [ dlopen " path -- dll " [ 1 | 1 ] ]
+ [ dlsym " name dll -- ptr " [ 2 | 1 ] ]
+ [ dlsym-self " name -- ptr " [ 1 | 1 ] ]
+ [ dlclose " dll -- " [ 1 | 0 ] ]
+ [ <alien> " ptr -- alien " [ 1 | 1 ] ]
+ [ <local-alien> " len -- alien " [ 1 | 1 ] ]
+ [ alien-cell " alien off -- n " [ 2 | 1 ] ]
+ [ set-alien-cell " n alien off -- " [ 3 | 0 ] ]
+ [ alien-4 " alien off -- n " [ 2 | 1 ] ]
+ [ set-alien-4 " n alien off -- " [ 3 | 0 ] ]
+ [ alien-2 " alien off -- n " [ 2 | 1 ] ]
+ [ set-alien-2 " n alien off -- " [ 3 | 0 ] ]
+ [ alien-1 " alien off -- n " [ 2 | 1 ] ]
+ [ set-alien-1 " n alien off -- " [ 3 | 0 ] ]
+ [ heap-stats " -- instances bytes " [ 0 | 2 ] ]
+ [ throw " error -- " [ 1 | 0 ] ]
+] [
+ uncons dupd uncons car ( word word stack-effect infer-effect )
+ >r "stack-effect" set-word-property r>
+ "infer-effect" set-word-property
+] each
USE: math
USE: stack
+: power-of-2? ( n -- ? )
+ dup dup neg bitand = ;
+
+: (random-int-0) ( n bits val -- n )
+ 3dup - + pred 0 < [
+ 2drop (random-int) 2dup swap mod (random-int-0)
+ ] [
+ nip nip
+ ] ifte ;
+
+: random-int-0 ( max -- n )
+ succ dup power-of-2? [
+ (random-int) * -31 shift
+ ] [
+ (random-int) 2dup swap mod (random-int-0)
+ ] ifte ;
+
+: random-int ( min max -- n )
+ dupd swap - random-int-0 + ;
+
+: random-boolean ( -- ? )
+ 0 1 random-int 0 = ;
+
+! TODO: : random-float ... ;
+
: random-digit ( -- digit )
0 9 random-int ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: stack
+USE: vectors
+
+: nop ( -- ) ;
+: 2drop ( x x -- ) drop drop ;
+: 3drop ( x x x -- ) drop drop drop ;
+: 2dup ( x y -- x y x y ) over over ;
+: 3dup ( x y z -- x y z x y z ) pick pick pick ;
+: -rot ( x y z -- z x y ) rot rot ;
+: dupd ( x y -- x x y ) >r dup r> ;
+: swapd ( x y z -- y x z ) >r swap r> ;
+: transp ( x y z -- z y x ) swap rot ;
+: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ;
+
+: clear ( -- )
+ #! Clear the datastack. For interactive use only; invoking
+ #! this from a word definition will clobber any values left
+ #! on the data stack by the caller.
+ { } set-datastack ;
+
+: depth ( -- n )
+ #! Push the number of elements on the datastack.
+ datastack vector-length ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 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: stdio
-USE: math
-USE: stack
-USE: streams
-USE: strings
-
-: read-little-endian-32 ( -- word )
- read1
- read1 8 shift bitor
- read1 16 shift bitor
- read1 24 shift bitor ;
-
-: read-big-endian-32 ( -- word )
- read1 24 shift
- read1 16 shift bitor
- read1 8 shift bitor
- read1 bitor ;
-
-: byte7 ( num -- byte ) -56 shift HEX: ff bitand ;
-: byte6 ( num -- byte ) -48 shift HEX: ff bitand ;
-: byte5 ( num -- byte ) -40 shift HEX: ff bitand ;
-: byte4 ( num -- byte ) -32 shift HEX: ff bitand ;
-: byte3 ( num -- byte ) -24 shift HEX: ff bitand ;
-: byte2 ( num -- byte ) -16 shift HEX: ff bitand ;
-: byte1 ( num -- byte ) -8 shift HEX: ff bitand ;
-: byte0 ( num -- byte ) HEX: ff bitand ;
-
-: write-little-endian-64 ( word -- )
- dup byte0 >char write
- dup byte1 >char write
- dup byte2 >char write
- dup byte3 >char write
- dup byte4 >char write
- dup byte5 >char write
- dup byte6 >char write
- byte7 >char write ;
-
-: write-big-endian-64 ( word -- )
- dup byte7 >char write
- dup byte6 >char write
- dup byte5 >char write
- dup byte4 >char write
- dup byte3 >char write
- dup byte2 >char write
- dup byte1 >char write
- byte0 >char write ;
-
-: write-little-endian-32 ( word -- )
- dup byte0 >char write
- dup byte1 >char write
- dup byte2 >char write
- byte3 >char write ;
-
-: write-big-endian-32 ( word -- )
- dup byte3 >char write
- dup byte2 >char write
- dup byte1 >char write
- byte0 >char write ;
-
-: write-little-endian-16 ( char -- )
- dup byte0 >char write
- byte1 >char write ;
-
-: write-big-endian-16 ( char -- )
- dup byte1 >char write
- byte0 >char write ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 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: streams
-DEFER: <extend-stream>
-
-IN: stdio
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: namespaces
-USE: stack
-USE: streams
-
-: flush ( -- )
- "stdio" get fflush ;
-
-: read ( -- string )
- "stdio" get freadln ;
-
-: read1 ( count -- string )
- "stdio" get fread1 ;
-
-: read# ( count -- string )
- "stdio" get fread# ;
-
-: write ( string -- )
- "stdio" get fwrite ;
-
-: write-attr ( string style -- )
- #! Write an attributed string to standard output.
- "stdio" get fwrite-attr ;
-
-: write-icon ( resource -- )
- #! Write an icon. Eg, /library/icons/File.png
- "icon" swons unit "" swap write-attr ;
-
-: print ( string -- )
- "stdio" get fprint ;
-
-: terpri ( -- )
- #! Print a newline to standard output.
- "\n" write ;
-
-: close ( -- )
- "stdio" get fclose ;
-
-: with-stream ( stream quot -- )
- [ swap "stdio" set [ close rethrow ] catch ] with-scope ;
-
-: with-string ( quot -- str )
- #! Execute a quotation, and push a string containing all
- #! text printed by the quotation.
- 1024 <string-output-stream> [
- call "stdio" get stream>str
- ] with-stream ;
-
-: <stdio-stream> ( stream -- stream )
- #! We disable fclose on stdio so that various tricks like
- #! with-stream can work.
- <extend-stream> [
- ( string -- )
- [ write "\n" write flush ] "fprint" set
-
- [ ] "fclose" set
- ] extend ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 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: streams
-USE: combinators
-USE: errors
-USE: kernel
-USE: namespaces
-USE: stack
-USE: strings
-
-! Generic functions, of sorts...
-
-: fflush ( stream -- )
- [ "fflush" get call ] bind ;
-
-: freadln ( stream -- string )
- [ "freadln" get call ] bind ;
-
-: fread1 ( stream -- string )
- [ "fread1" get call ] bind ;
-
-: fread# ( count stream -- string )
- [ "fread#" get call ] bind ;
-
-: fprint ( string stream -- )
- [ "fprint" get call ] bind ;
-
-: fwrite ( string stream -- )
- [ "fwrite" get call ] bind ;
-
-: fwrite-attr ( string style stream -- )
- #! Write an attributed string to the given stream.
- #! Supported keys depend on the type of stream.
- [ "fwrite-attr" get call ] bind ;
-
-: fclose ( stream -- )
- [ "fclose" get call ] bind ;
-
-: <stream> ( -- stream )
- #! Create a stream object.
- <namespace> [
- ( -- string )
- [ "freadln not implemented." throw ] "freadln" set
- ( -- string )
- [
- 1 namespace fread# dup f-or-"" [
- 0 swap str-nth
- ] unless
- ] "fread1" set
- ( count -- string )
- [ "fread# not implemented." throw ] "fread#" set
- ( string -- )
- [ "fwrite not implemented." throw ] "fwrite" set
- ( string style -- )
- [ drop namespace fwrite ] "fwrite-attr" set
- ( -- )
- [ ] "fflush" set
- ( -- )
- [ ] "fclose" set
- ( string -- )
- [
- namespace fwrite
- "\n" namespace fwrite
- ] "fprint" set
- ] extend ;
-
-: <string-output-stream> ( size -- stream )
- #! Creates a new stream for writing to a string buffer.
- <stream> [
- <sbuf> "buf" set
- ( string -- )
- [ "buf" get sbuf-append ] "fwrite" set
- ] extend ;
-
-: stream>str ( stream -- string )
- #! Returns the string written to the given string output
- #! stream.
- [ "buf" get ] bind sbuf>str ;
! string.
80 <sbuf> swap [ [ over sbuf-append ] when* ] each sbuf>str ;
+: cat2 ( "a" "b" -- "ab" )
+ swap
+ 80 <sbuf>
+ dup >r sbuf-append r>
+ dup >r sbuf-append r>
+ sbuf>str ;
+
: cat3 ( "a" "b" "c" -- "abc" )
[ ] cons cons cons cat ;
#! index.
[ swap str-head ] 2keep succ swap str-tail ;
-: >title ( str -- str )
- 1 str/ >r >upper r> >lower cat2 ;
-
: str-headcut ( str begin -- str str )
str-length str/ ;
--- /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: threads
+USE: combinators
+USE: continuations
+USE: io-internals
+USE: kernel
+USE: lists
+USE: stack
+
+! Core of the multitasker. Used by io-internals.factor and
+! in-thread.factor.
+
+: run-queue ( -- queue )
+ 9 getenv ;
+
+: set-run-queue ( queue -- )
+ 9 setenv ;
+
+: init-threads ( -- )
+ f set-run-queue ;
+
+: next-thread ( -- quot )
+ #! Get and remove the next quotation from the run queue.
+ run-queue dup [ uncons set-run-queue ] when ;
+
+: schedule-thread ( quot -- )
+ #! Add a quotation to the run queue.
+ run-queue cons set-run-queue ;
+
+: (yield) ( -- )
+ #! If there is a quotation in the run queue, call it,
+ #! otherwise wait for I/O. The currently executing
+ #! continuation is suspended. Use yield instead.
+ next-thread [
+ call
+ ] [
+ next-io-task [
+ call
+ ] [
+ (yield)
+ ] ifte*
+ ] ifte* ;
+
+: yield ( -- )
+ #! Add the current continuation to the run queue, and yield
+ #! to the next quotation. The current continuation will
+ #! eventually be restored by a future call to (yield) or
+ #! yield.
+ [ schedule-thread (yield) ] callcc0 ;
+++ /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: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: parser
-USE: real-math
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-USE: vectors
-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
-
-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: arithmetic-type
-DEFER: >fraction
-DEFER: fraction>
-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>=
-
-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
- nip
- tuck
- rot
- >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
- ] [
- swap succ tuck primitive,
- ] each drop ;
-
-: version, ( -- )
- "version" [ "kernel" ] search version unit compound, ;
-
-: make-image ( name -- )
- #! Make an image for the C interpreter.
- [
- "/library/platform/native/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 ;
USE: stdio
USE: strings
USE: unparser
+USE: vectors
+USE: words
+USE: math
+
+: expired-error ( obj -- )
+ "Object did not survive image save/load: " write . ;
+
+: io-task-twice-error ( obj -- )
+ "Attempting to perform two simultaneous I/O operations on "
+ write . ;
+
+: no-io-tasks-error ( obj -- )
+ "No I/O tasks" print ;
+
+: undefined-word-error ( obj -- )
+ "Undefined word: " write . ;
+
+: incompatible-port-error ( obj -- )
+ "Unsuitable port for operation: " write . ;
+
+: io-error ( list -- )
+ "I/O error in kernel function " write
+ unswons write ": " write car print ;
+
+: type-check-error ( list -- )
+ "Type check error" print
+ uncons car dup "Object: " write .
+ "Object type: " write type type-name print
+ "Expected type: " write type-name print ;
+
+: array-range-error ( list -- )
+ "Array range check error" print
+ unswons "Object: " write .
+ uncons car "Maximum index: " write .
+ "Requested index: " write . ;
+
+: float-format-error ( list -- )
+ "Invalid floating point literal format: " write . ;
+
+: signal-error ( obj -- )
+ "Operating system signal " write . ;
+
+: negative-array-size-error ( obj -- )
+ "Cannot allocate array with negative size " write . ;
+
+: bad-primitive-error ( obj -- )
+ "Bad primitive number: " write . ;
+
+: c-string-error ( obj -- )
+ "Cannot convert to C string: " write . ;
+
+: ffi-disabled-error ( obj -- )
+ drop "Recompile Factor with #define FFI." print ;
+
+: ffi-error ( obj -- )
+ "FFI: " write print ;
+
+: port-closed-error ( obj -- )
+ "Port closed: " write . ;
+
+: kernel-error. ( obj n -- str )
+ {
+ expired-error
+ io-task-twice-error
+ no-io-tasks-error
+ incompatible-port-error
+ io-error
+ undefined-word-error
+ type-check-error
+ array-range-error
+ float-format-error
+ signal-error
+ negative-array-size-error
+ bad-primitive-error
+ c-string-error
+ ffi-disabled-error
+ ffi-error
+ port-closed-error
+ } vector-nth execute ;
+
+: kernel-error? ( obj -- ? )
+ dup cons? [ uncons cons? swap fixnum? and ] [ drop f ] ifte ;
+
+: error. ( error -- str )
+ dup kernel-error? [
+ uncons car swap kernel-error.
+ ] [
+ dup string? [ print ] [ . ] ifte
+ ] ifte ;
: standard-dump ( error -- )
"ERROR: " write error. ;
+++ /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.
-
-! This library allows one to generate a new set of bootstrap
-! images (boot.image.{le32,le64,be32,be64}.
-!
-! It does this by parsing the set of source files needed to
-! generate the minimal image, and writing the cons cells, words,
-! strings etc to the image file in the CFactor object memory
-! format.
-!
-! What is a bootstrap image? It basically contains enough code
-! to parse a source file. See platform/native/boot.factor --
-! It initializes the core interpreter services, and proceeds to
-! run platform/native/boot-stage2.factor.
-
-IN: namespaces
-
-( Java Factor doesn't have this )
-: namespace-buckets 23 ;
-
-IN: image
-USE: combinators
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: random
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-USE: test
-USE: vectors
-USE: unparser
-USE: words
-
-: image "image" get ;
-: emit ( cell -- ) image vector-push ;
-
-: fixup ( value offset -- ) image set-vector-nth ;
-
-( Object memory )
-
-: image-magic HEX: 0f0e0d0c ;
-: image-version 0 ;
-
-: cell "64-bits" get 8 4 ? ;
-: char "64-bits" get 4 2 ? ;
-
-: tag-mask BIN: 111 ;
-: tag-bits 3 ;
-
-: untag ( cell tag -- ) tag-mask bitnot bitand ;
-: tag ( cell -- tag ) tag-mask bitand ;
-
-: fixnum-tag BIN: 000 ;
-: word-tag BIN: 001 ;
-: cons-tag BIN: 010 ;
-: object-tag BIN: 011 ;
-: ratio-tag BIN: 100 ;
-: complex-tag BIN: 101 ;
-: header-tag BIN: 110 ;
-: gc-fwd-ptr BIN: 111 ; ( we don't output these )
-
-: f-type 6 ;
-: t-type 7 ;
-: array-type 8 ;
-: bignum-type 9 ;
-: float-type 10 ;
-: vector-type 11 ;
-: string-type 12 ;
-
-: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
-: >header ( id -- tagged ) header-tag immediate ;
-
-( Image header )
-
-: base
- #! We relocate the image to after the header, and leaving
- #! two empty cells. This lets us differentiate an F pointer
- #! (0/tag 3) from a pointer to the first object in the
- #! image.
- 2 cell * ;
-
-: header ( -- )
- image-magic emit
- image-version emit
- ( relocation base at end of header ) base emit
- ( bootstrap quotation set later ) 0 emit
- ( global namespace set later ) 0 emit
- ( size of heap set later ) 0 emit ;
-
-: boot-quot-offset 3 ;
-: global-offset 4 ;
-: heap-size-offset 5 ;
-: header-size 6 ;
-
-( Allocator )
-
-: here ( -- size )
- image vector-length header-size - cell * base + ;
-
-: here-as ( tag -- pointer )
- here swap bitor ;
-
-: pad ( -- )
- here 8 mod 4 = [ 0 emit ] when ;
-
-( Remember what objects we've compiled )
-
-: pooled-object ( object -- pointer )
- "objects" get hash ;
-
-: pool-object ( object pointer -- )
- swap "objects" get set-hash ;
-
-( Fixnums )
-
-: 'fixnum ( n -- tagged ) fixnum-tag immediate ;
-
-( Bignums )
-
-: 'bignum ( bignum -- tagged )
- object-tag here-as >r
- bignum-type >header emit
- dup 0 = 1 2 ? emit ( capacity )
- [
- [ 0 = ] [ emit pad ]
- [ 0 < ] [ 1 emit neg emit ]
- [ 0 > ] [ 0 emit emit ]
- ] cond r> ;
-
-( Special objects )
-
-! Padded with fixnums for 8-byte alignment
-
-: t,
- object-tag here-as "t" set
- t-type >header emit
- 0 'fixnum emit ;
-
-: 0, 0 'bignum drop ;
-: 1, 1 'bignum drop ;
-: -1, -1 'bignum drop ;
-
-( Beginning of the image )
-! The image proper begins with the header, then T,
-! and the bignums 0, 1, and -1.
-
-: begin ( -- ) header t, 0, 1, -1, ;
-
-( Words )
-
-: word, ( -- pointer )
- word-tag here-as word-tag >header emit
- 0 HEX: fffffff random-int emit ( hashcode )
- 0 emit ;
-
-! This is to handle mutually recursive words
-
-: fixup-word ( word -- offset )
- dup pooled-object dup [
- nip
- ] [
- drop "Not in image: " swap word-name cat2 throw
- ] ifte ;
-
-: fixup-words ( -- )
- "image" get [
- dup word? [ fixup-word ] when
- ] vector-map "image" set ;
-
-: 'word ( word -- pointer )
- dup pooled-object dup [ nip ] [ drop ] ifte ;
-
-( Conses )
-
-DEFER: '
-
-: cons, ( -- pointer ) cons-tag here-as ;
-: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
-
-( Ratios -- almost the same as a cons )
-
-: ratio, ( -- pointer ) ratio-tag here-as ;
-: 'ratio ( a/b -- tagged )
- dup denominator ' swap numerator ' ratio, -rot emit emit ;
-
-( Complex -- almost the same as ratio )
-
-: complex, ( -- pointer ) complex-tag here-as ;
-: 'complex ( #{ a b } -- tagged )
- dup imaginary ' swap real ' complex, -rot emit emit ;
-
-( Strings )
-
-: align-string ( n str -- )
- tuck str-length - CHAR: \0 fill cat2 ;
-
-: emit-string ( str -- )
- "big-endian" get [ str-reverse ] unless
- 0 swap [ swap 16 shift + ] str-each emit ;
-
-: (pack-string) ( n list -- )
- #! Emit bytes for a string, with n characters per word.
- [
- 2dup str-length > [ dupd align-string ] when
- emit-string
- ] each drop ;
-
-: pack-string ( string -- )
- char tuck swap split-n (pack-string) ;
-
-: string, ( string -- )
- object-tag here-as swap
- string-type >header emit
- dup str-length emit
- dup hashcode emit
- pack-string
- pad ;
-
-: 'string ( string -- pointer )
- #! We pool strings so that each string is only written once
- #! to the image
- dup pooled-object dup [
- nip
- ] [
- drop dup string, dup >r pool-object r>
- ] 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 ;
-
-: 'plist ( word -- plist )
- [
- dup word-name "name" swons ,
- dup word-vocabulary "vocabulary" swons ,
- "parsing" word-property [ t "parsing" swons , ] when
- ] make-list ' ;
-
-: (worddef,) ( word primitive parameter -- )
- ' >r >r dup (word+) dup 'plist >r
- word, pool-object
- r> ( -- plist )
- r> ( primitive -- ) emit
- r> ( parameter -- ) emit
- ( plist -- ) emit
- 0 emit ( padding )
- 0 emit ;
-
-: primitive, ( word primitive -- ) f (worddef,) ;
-: compound, ( word definition -- ) 1 swap (worddef,) ;
-
-( Arrays and vectors )
-
-: 'array ( list -- untagged )
- [ ' ] map
- here >r
- array-type >header emit
- dup length emit
- ( elements -- ) [ emit ] each
- pad r> ;
-
-: 'vector ( vector -- pointer )
- dup vector>list 'array swap vector-length
- object-tag here-as >r
- vector-type >header emit
- emit ( length )
- emit ( array ptr )
- pad r> ;
-
-( Cross-compile a reference to an object )
-
-: ' ( obj -- pointer )
- [
- [ fixnum? ] [ 'fixnum ]
- [ bignum? ] [ 'bignum ]
- [ ratio? ] [ 'ratio ]
- [ complex? ] [ 'complex ]
- [ word? ] [ 'word ]
- [ cons? ] [ 'cons ]
- [ char? ] [ 'fixnum ]
- [ string? ] [ 'string ]
- [ vector? ] [ 'vector ]
- [ t = ] [ drop "t" get ]
- ! f is #define F RETAG(0,OBJECT_TYPE)
- [ f = ] [ drop object-tag ]
- [ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
- ] cond ;
-
-( End of the image )
-
-: (set-boot) ( quot -- ) ' boot-quot-offset fixup ;
-: (set-global) ( namespace -- ) ' global-offset fixup ;
-
-: global, ( -- )
- "vocabularies" get "vocabularies"
- namespace-buckets <hashtable>
- dup >r set-hash r> (set-global) ;
-
-: end ( -- )
- global,
- fixup-words
- here base - heap-size-offset fixup ;
-
-( Image output )
-
-: write-word ( word -- )
- "64-bits" get [
- "big-endian" get [
- write-big-endian-64
- ] [
- write-little-endian-64
- ] ifte
- ] [
- "big-endian" get [
- write-big-endian-32
- ] [
- write-little-endian-32
- ] ifte
- ] ifte ;
-
-: write-image ( image file -- )
- <filebw> [ [ write-word ] vector-each ] with-stream ;
-
-: with-minimal-image ( quot -- image )
- [
- 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.
- 1000 <vector> "word-fixups" set
- call
- "image" get
- ] with-scope ;
-
-: with-image ( quot -- image )
- [ begin call end ] with-minimal-image ;
-
-: test-image ( quot -- ) with-image vector>list . ;
--- /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
+
+IN: math : fixnum? ( obj -- ? ) type 0 eq? ;
+IN: words : word? ( obj -- ? ) type 1 eq? ;
+IN: lists : cons? ( obj -- ? ) type 2 eq? ;
+IN: math : ratio? ( obj -- ? ) type 4 eq? ;
+IN: math : complex? ( obj -- ? ) type 5 eq? ;
+IN: math : bignum? ( obj -- ? ) type 9 eq? ;
+IN: math : float? ( obj -- ? ) type 10 eq? ;
+IN: vectors : vector? ( obj -- ? ) type 11 eq? ;
+IN: strings : string? ( obj -- ? ) type 12 eq? ;
+IN: strings : sbuf? ( obj -- ? ) type 13 eq? ;
+IN: io-internals : port? ( obj -- ? ) type 14 eq? ;
+IN: alien : dll? ( obj -- ? ) type 15 eq? ;
+IN: alien : alien? ( obj -- ? ) type 16 eq? ;
+
+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 ;
USE: lists
USE: math
USE: stack
+USE: combinators
: 2vector-nth ( n vec vec -- obj obj )
>r over >r vector-nth r> r> vector-nth ;
: vector-clone ( vector -- vector )
#! Shallow copy of a vector.
[ ] vector-map ;
+
+: ?vector= ( n vec vec -- ? )
+ #! Reached end?
+ drop vector-length = ;
+
+: (vector=) ( n vec vec -- ? )
+ 3dup ?vector= [
+ 3drop t ( reached end without any unequal elts )
+ ] [
+ 3dup 2vector-nth = [
+ >r >r succ r> r> (vector=)
+ ] [
+ 3drop f
+ ] ifte
+ ] ifte ;
+
+: vector-length= ( vec vec -- ? )
+ vector-length swap vector-length number= ;
+
+: vector= ( obj vec -- ? )
+ #! Check if two vectors are equal. Two vectors are
+ #! considered equal if they have the same length and contain
+ #! equal elements.
+ 2dup eq? [
+ 2drop t
+ ] [
+ over vector? [
+ 2dup vector-length= [
+ 0 -rot (vector=)
+ ] [
+ 2drop f
+ ] ifte
+ ] [
+ 2drop f
+ ] ifte
+ ] ifte ;
+
+: ?vector-nth ( n vec -- obj/f )
+ 2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ;
+
+: vector-hashcode ( vec -- n )
+ 0 swap 4 [
+ over ?vector-nth hashcode rot bitxor swap
+ ] times* drop ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: words
+USE: combinators
+USE: hashtables
+USE: lists
+USE: namespaces
+USE: stack
+
+: (search) ( name vocab -- word )
+ vocab dup [ hash ] [ 2drop f ] ifte ;
+
+: search ( name list -- word )
+ #! Search for a word in a list of vocabularies.
+ dup [
+ 2dup car (search) dup [
+ nip nip ( found )
+ ] [
+ drop cdr search ( check next )
+ ] ifte
+ ] [
+ 2drop f ( not found )
+ ] ifte ;
+
+: <plist> ( name vocab -- plist )
+ "vocabulary" swons swap "name" swons 2list ;
+
+: (create) ( name vocab -- word )
+ #! Create an undefined word without adding to a vocabulary.
+ <plist> 0 f rot <word> ;
+
+: reveal ( word -- )
+ #! Add a new word to its vocabulary.
+ global [
+ "vocabularies" get [
+ dup word-vocabulary
+ over word-name
+ 2list set-object-path
+ ] bind
+ ] bind ;
+
+: create ( name vocab -- word )
+ #! Create a new word in a vocabulary. If the vocabulary
+ #! already contains the word, the existing instance is
+ #! returned.
+ 2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: presentation
-USE: combinators
-USE: hashtables
-USE: lists
-USE: kernel
-USE: namespaces
-USE: stack
-USE: words
-
-: vocab-style ( vocab -- style )
- #! Each vocab has a style object specifying how words are
- #! to be printed.
- "vocabularies" style hash ;
-
-: set-vocab-style ( style vocab -- )
- >r default-style append r> "vocabularies" style set-hash ;
-
-: word-style ( word -- style )
- word-vocabulary [ vocab-style ] [ default-style ] ifte* ;
-
-<namespace> "vocabularies" set-style
-
-[
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 204 0 0 ] ]
-] "arithmetic" set-vocab-style
-[
- [ "ansi-fg" | "3" ]
- [ "fg" | [ 255 132 0 ] ]
-] "combinators" set-vocab-style
-[
- [ "ansi-fg" | "5" ]
- [ "fg" | [ 102 0 204 ] ]
-] "continuations" set-vocab-style
-[
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 255 0 0 ] ]
-] "errors" set-vocab-style
-[
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 153 102 255 ] ]
-] "hashtables" set-vocab-style
-[
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 0 102 153 ] ]
-] "lists" set-vocab-style
-[
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 0 153 102 ] ]
-] "logic" set-vocab-style
-[
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 204 0 0 ] ]
-] "math" set-vocab-style
-[
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 0 153 255 ] ]
-] "namespaces" set-vocab-style
-[
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 102 204 255 ] ]
-] "parser" set-vocab-style
-[
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 102 204 255 ] ]
-] "prettyprint" set-vocab-style
-[
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 0 0 0 ] ]
-] "stack" set-vocab-style
-[
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 204 0 204 ] ]
-] "stdio" set-vocab-style
-[
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 102 0 204 ] ]
-] "streams" set-vocab-style
-[
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 255 0 204 ] ]
-] "strings" set-vocab-style
-[
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 102 204 255 ] ]
-] "unparser" set-vocab-style
-[
- [ "ansi-fg" | "3" ]
- [ "fg" | [ 2 185 2 ] ]
-] "vectors" set-vocab-style
-[
- [ "fg" | [ 128 128 128 ] ]
-] "syntax" set-vocab-style
USE: kernel
USE: lists
USE: logic
+USE: math
USE: namespaces
USE: stack
USE: strings
+: word-property ( word pname -- pvalue )
+ swap word-plist assoc ;
+
+: set-word-property ( word pvalue pname -- )
+ pick word-plist
+ pick [ set-assoc ] [ remove-assoc nip ] ifte
+ swap set-word-plist ;
+
+: ?word-primitive ( obj -- prim/0 )
+ dup word? [ word-primitive ] [ drop 0 ] ifte ;
+
+: defined? ( obj -- ? ) ?word-primitive 0 = not ;
+: compound? ( obj -- ? ) ?word-primitive 1 = ;
+: primitive? ( obj -- ? ) ?word-primitive 2 > ;
+: symbol? ( obj -- ? ) ?word-primitive 2 = ;
+
+: word ( -- word ) global [ "last-word" get ] bind ;
+: set-word ( word -- ) global [ "last-word" set ] bind ;
+
+: define-compound ( word def -- )
+ over set-word-parameter
+ 1 over set-word-primitive
+ f "parsing" set-word-property ;
+
+: define-symbol ( word -- )
+ dup dup set-word-parameter
+ 2 swap set-word-primitive ;
+
: word-name ( word -- name )
"name" word-property ;
: word-vocabulary ( word -- vocab )
"vocabulary" word-property ;
+: 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 ;
projects / factor.git / commitdiff