- add a socket timeout\r
-- fix error postoning -- not all errors thrown by i/o code are\r
- postponed\r
+- compiling when*\r
+- compiling unless*\r
+- getenv/setenv: if literal arg, compile as a load/store\r
+- inline words\r
+- alist -vs- assoc terminology\r
+- compiler: drop literal peephole optimization\r
+- [ 2 2 . ] run fails\r
\r
+ compiler/ffi:\r
\r
- struct membres that are not *\r
- float types\r
- compile word twice; no more 'cannot compile' error!\r
-- compiler: drop literal peephole optimization\r
-- compiling when*\r
-- compiling unless*\r
-- getenv/setenv: if literal arg, compile as a load/store\r
-- inline words\r
- perhaps /i should work with all numbers\r
\r
+ docs:\r
- 'cascading' styles\r
- command line parsing cleanup\r
- nicer way to combine two paths\r
-- alist -vs- assoc terminology\r
\r
+ httpd:\r
\r
! DeJong attractor renderer.
! To run this code, start your interpreter like so:
!
-! ./f -library:sdl=libSDL.so -library:sdl-gfx=libSDL_gfx.so
+! ./f -libraries:sdl=libSDL.so -libraries:sdl-gfx=libSDL_gfx.so
!
! Then, enter this at the interpreter prompt:
!
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: irc
-USE: arithmetic
USE: combinators
USE: errors
USE: inspector
-USE: interpreter
+USE: listener
USE: kernel
USE: lists
USE: logic
"ACTION " write write " :" write print ;
: keep-datastack ( quot -- )
- datastack [ call ] dip set-datastack drop ;
+ datastack slip set-datastack drop ;
: irc-stream-write ( string -- )
dup "buf" get sbuf-append
: with-irc-stream ( recepient quot -- )
[
- [ "stdio" get swap <irc-stream> "stdio" set ] dip
- call
+ >r "stdio" get swap <irc-stream> "stdio" set r> call
] with-scope ;
: irc-action-quot ( action -- quot )
] with-pixels ;
: mandel ( -- )
- 640 480 32 SDL_HWSURFACE SDL_FULLSCREEN bitor SDL_SetVideoMode drop
+ 640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
[
- 3 zoom-fact set
+ 0.8 zoom-fact set
-0.65 center set
100 nb-iter set
[ render ] time
+++ /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: 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
-
-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
- 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 ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or wxithout
-! 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: logic
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: strings
-USE: unparser
-
-: standard-dump ( error -- )
- "ERROR: " write error. ;
-
-: parse-dump ( error -- )
- <%
- "error-file" get [ "<interactive>" ] unless* % ":" %
- "error-line-number" get [ 1 ] unless* unparse % ": " %
- %> write
- error.
-
- "error-line" get print
-
- <% "error-col" get " " fill % "^" % %> print ;
-
-: in-parser? ( -- ? )
- "error-line" get "error-col" get and ;
-
-: error-handler-hook
- #! The game overrides this.
- ;
-
-: default-error-handler ( error -- )
- #! Print the error and return to the top level.
- [
- in-parser? [ parse-dump ] [ standard-dump ] ifte
-
- ":s :r :n :c show stacks at time of error." print
-
- java? [ ":j shows Java stack trace." print ] when
- error-handler-hook
-
- ] when* ;
-
-: :s ( -- ) "error-datastack" get {.} ;
-: :r ( -- ) "error-callstack" get {.} ;
-: :n ( -- ) "error-namestack" get {.} ;
-: :c ( -- ) "error-catchstack" get {.} ;
+++ /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
-
- ,] ' ;
-
-: (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=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: inferior
-USE: combinators
-USE: errors
-USE: interpreter
-USE: kernel
-USE: lists
-USE: logic
-USE: namespaces
-USE: parser
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-USE: presentation
-
-! The purpose of this library is to allow CFactor to be embedded
-! inside the Java Factor listener in jEdit.
-!
-! Eg, in Java Factor, you could evaluate this after fixing the
-! paths accordingly:
-!
-! : (inf
-! [
-! "/home/slava/Factor/f"
-! "/home/slava/Factor/factor.image"
-! "-no-ansi"
-! ] pipe inferior-client ;
-!
-! Details:
-!
-! Packets have the following form:
-! 1 byte -- type. CHAR: w: write, CHAR: r: read
-! 4 bytes -- for write only -- length of write request
-! remaining -- unparsed write request -- string then style
-
-! After a read line request, the server reads a response from
-! the client:
-! 4 bytes -- length. -1 means EOF
-! remaining -- input
-
-! All multi-byte integers are big endian signed.
-
-: inferior-server-read ( -- str )
- CHAR: r write flush read-big-endian-32 read# ;
-
-: inferior-server-write-attr ( str style -- )
- CHAR: w write
- [ swap . . ] with-string
- dup str-length write-big-endian-32
- write ;
-
-: inferior-server-flush ( -- )
- CHAR: f write flush ;
-
-: <inferior-server-stream> ( stream -- stream )
- <extend-stream> [
- ( -- str )
- [ inferior-server-read ] "freadln" set
- ( str -- )
- [
- default-style inferior-server-write-attr
- ] "fwrite" set
- ( str style -- )
- [ inferior-server-write-attr ] "fwrite-attr" set
- ( string -- )
- [
- "\n" cat2 default-style inferior-server-write-attr
- ] "fprint" set
- ( -- )
- [ inferior-server-flush ] "fflush" set
- ] extend ;
-
-: inferior-client-read ( stream -- ? )
- freadln dup [
- dup str-length write-big-endian-32 write flush t
- ] [
- drop 0 write-big-endian-32 flush f
- ] ifte ;
-
-: inferior-client-write ( stream -- ? )
- read-big-endian-32 read# dup [
- parse dup [
- uncons car rot fwrite-attr t
- ] [
- 2drop f
- ] ifte
- ] when ;
-
-: inferior-client-packet ( stream -- ? )
- #! Read from an inferior client socket and print attributed
- #! strings that were read to standard output.
- read1 [
- [ not ] [ 2drop f ( EOF ) ]
- [ CHAR: r = ] [ drop inferior-client-read ]
- [ CHAR: w = ] [ drop inferior-client-write ]
- [ CHAR: f = ] [ drop fflush t ]
- [ drop t ] [ "Invalid packet type: " swap cat2 throw ]
- ] cond ;
-
-: inferior-client-loop ( stream -- )
- #! The stream is the stream to write to.
- dup inferior-client-packet [
- inferior-client-loop
- ] [
- drop
- ] ifte ;
-
-: inferior-server ( -- )
- #! Execute this in the inferior Factor.
- terpri
- "inferior-ack" print flush
- "stdio" get <inferior-server-stream> "stdio" set ;
-
-: inferior-read-ack ( -- )
- read [
- "inferior-ack" = [ inferior-read-ack ] unless
- ] when* ;
-
-: inferior-client ( from -- )
- #! Execute this in the superior Factor, with a socket to
- #! the inferior Factor as a parameter.
- "stdio" get swap [
- "USE: inferior inferior-server" print flush
- inferior-read-ack
- inferior-client-loop
- ] with-stream ;
USE: continuations
USE: errors
USE: files
-USE: interpreter
+USE: listener
USE: kernel
USE: lists
USE: namespaces
: parse-command-line ( args -- )
#! Parse command line arguments.
parse-switches run-files ;
-
-: init-interpreter ( -- )
- print-banner
- room.
-
- interpreter-loop ;
+++ /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: words
-USE: combinators
-USE: inspector
-USE: lists
-USE: kernel
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: strings
-USE: unparser
-
-: word-uses? ( of in -- ? )
- 2dup = [
- 2drop f ! Don't say that a word uses itself
- ] [
- word-parameter tree-contains?
- ] ifte ;
-
-: usages-in-vocab ( of vocab -- usages )
- #! Push a list of all usages of a word in a vocabulary.
- words [
- dup compound? [
- dupd word-uses?
- ] [
- drop f ! Ignore words without a definition
- ] ifte
- ] subset nip ;
-
-: usages-in-vocab. ( of vocab -- )
- #! List all usages of a word in a vocabulary.
- tuck usages-in-vocab dup [
- swap "IN: " write print [.]
- ] [
- 2drop
- ] ifte ;
-
-: usages. ( word -- )
- #! List all usages of a word in all vocabularies.
- vocabs [ dupd usages-in-vocab. ] each drop ;
-
-: vocab-apropos ( substring vocab -- list )
- #! Push a list of all words in a vocabulary whose names
- #! contain a string.
- words [ word-name dupd str-contains? ] subset nip ;
-
-: vocab-apropos. ( substring vocab -- )
- #! List all words in a vocabulary that contain a string.
- tuck vocab-apropos dup [
- "IN: " write swap print [.]
- ] [
- 2drop
- ] ifte ;
-
-: apropos. ( substring -- )
- #! List all words that contain a string.
- vocabs [ dupd vocab-apropos. ] each drop ;
-
-: in. ( -- )
- #! Print the vocabulary where new words are added in
- #! interactive parsers.
- "in" get print ;
-
-: use. ( -- )
- #! Print the vocabulary search path for interactive parsers.
- "use" get . ;
-
-: vocabs. ( -- )
- vocabs . ;
-
-: words. ( vocab -- )
- words . ;
+++ /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: inspector
-USE: combinators
-USE: format
-USE: kernel
-USE: hashtables
-USE: lists
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-USE: presentation
-USE: words
-USE: prettyprint
-USE: unparser
-USE: vectors
-
-: relative>absolute-object-path ( string -- string )
- "object-path" get [ "'" rot cat3 ] when* ;
-
-: vars. ( -- )
- #! Print a list of defined variables.
- vars [ print ] each ;
-
-: object-actions ( -- alist )
- [
- [ "Describe" | "describe-path" ]
- [ "Push" | "lookup" ]
- ] ;
-
-: link-style ( path -- style )
- relative>absolute-object-path
- dup "object-link" swons swap
- object-actions <actions> "actions" swons
- t "underline" swons
- 3list
- default-style append ;
-
-: var. ( [ name | value ] -- )
- uncons unparse swap link-style write-attr ;
-
-: var-name. ( max name -- )
- tuck unparse pad-string write dup link-style
- swap unparse swap write-attr ;
-
-: value. ( max name value -- )
- >r var-name. ": " write r> . ;
-
-: name-padding ( alist -- col )
- [ car unparse ] map max-str-length ;
-
-: describe-assoc ( alist -- )
- dup name-padding swap
- [ dupd uncons value. ] each drop ;
-
-: alist-sort ( list -- list )
- [ swap car unparse swap car unparse str-lexi> ] sort ;
-
-: describe-namespace ( namespace -- )
- [ vars-values ] bind alist-sort describe-assoc ;
-
-: describe-hashtable ( hashtables -- )
- hash>alist alist-sort describe-assoc ;
-
-: describe ( obj -- )
- [
- [ word? ]
- [ see ]
-
- [ string? ]
- [ print ]
-
- [ assoc? ]
- [ describe-assoc ]
-
- [ has-namespace? ]
- [ describe-namespace ]
-
- [ hashtable? ]
- [ describe-hashtable ]
-
- [ drop t ]
- [ prettyprint ]
- ] cond ;
-
-: lookup ( str -- object )
- global [ "'" split object-path ] bind ;
-
-: describe-path ( string -- )
- [ dup "object-path" set lookup describe ] with-scope ;
+++ /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: interpreter
-USE: combinators
-USE: continuations
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: parser
-USE: stack
-USE: stdio
-USE: strings
-USE: presentation
-USE: words
-USE: unparser
-USE: vectors
-
-: print-banner ( -- )
- <% "This is " % java? [ "JVM " % ] when
- native? [ "native " % ] when "Factor " % version % %> print
- "Copyright (C) 2003, 2004 Slava Pestov" print
- "Copyright (C) 2004 Chris Double" print
- "Type ``exit'' to exit, ``help'' for help." print ;
-
-: print-prompt ( -- )
- "ok" "prompt" style write-attr
- ! Print the space without a style, to workaround a bug in
- ! the GUI listener where the style from the prompt carries
- ! over to the input
- " " write flush ;
-
-: exit ( -- )
- "quit-flag" on ;
-
-: eval-catch ( str -- )
- [ eval ] [ [ default-error-handler drop ] when* ] catch ;
-
-: interpret ( -- )
- print-prompt read [ eval-catch ] [ exit ] ifte* ;
-
-: interpreter-loop ( -- )
- "quit-flag" get [
- "quit-flag" off
- ] [
- interpret interpreter-loop
- ] ifte ;
-
-: room. ( -- )
- room
- 1024 /i unparse write " KB total, " write
- 1024 /i unparse write " KB free" print ;
-
-: help ( -- )
- "SESSION:" print
- native? [
- "\"foo.image\" save-image -- save heap to a file" print
- ] when
- "room. -- show memory usage" print
- "garbage-collection -- force a GC" print
- "exit -- exit interpreter" print
- terpri
- "WORDS:" print
- "vocabs. -- list vocabularies" print
- "\"math\" words. -- list the math vocabulary" print
- "\"str\" apropos. -- list all words containing str" print
- "\\ neg see -- show word definition" print
- "\\ car usages. -- list all words invoking car" print
- terpri
- "STACKS:" print
- ".s .r .n .c -- show contents of the 4 stacks" print
- "clear -- clear datastack" print
- terpri
- "OBJECTS:" print
- "global describe -- list global variables." print
- "\"foo\" get . -- print a variable value." print
- ". -- print top of stack." print
- terpri
- "HTTP SERVER: USE: httpd 8888 httpd" print
- "TELNET SERVER: USE: telnetd 9999 telnetd" print ;
USE: combinators
USE: continuations
USE: init
-USE: interpreter
+USE: listener
USE: kernel
USE: lists
USE: namespaces
[
dup "console" set
<console-stream> "stdio" set
- init-interpreter
+ init-listener
] with-scope ;
"/library/extend-stream.factor" run-resource ! streams
"/library/platform/jvm/unparser.factor" run-resource ! unparser
"/library/platform/jvm/parser.factor" run-resource ! parser
-"/library/styles.factor" run-resource ! styles
+"/library/presentation.factor" run-resource ! presentation
!!! Math library.
"/library/platform/jvm/real-math.factor" run-resource ! real-math
"/library/vocabulary-style.factor" run-resource ! style
"/library/prettyprint.factor" run-resource ! prettyprint
"/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint
-"/library/interpreter.factor" run-resource ! interpreter
-"/library/inspector.factor" run-resource ! inspector
-"/library/inspect-vocabularies.factor" run-resource ! inspector
+"/library/tools/listener.factor" run-resource ! listener
+"/library/tools/inspector.factor" run-resource ! inspector
+"/library/tools/word-tools.factor" run-resource ! inspector
"/library/platform/jvm/compiler.factor" run-resource ! compiler
"/library/platform/jvm/debugger.factor" run-resource ! debugger
-"/library/debugger.factor" run-resource ! debugger
+"/library/tools/debugger.factor" run-resource ! debugger
!!! Final initialization...
"/library/init.factor" run-resource ! init
"/library/prettyprint.factor" run-resource ! prettyprint
"/library/files.factor" run-resource ! files
"/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint
-"/library/interpreter.factor" run-resource ! interpreter
-"/library/inspector.factor" run-resource ! inspector
-"/library/inspect-vocabularies.factor" run-resource ! inspector
+"/library/tools/listener.factor" run-resource ! listener
+"/library/tools/inspector.factor" run-resource ! inspector
+"/library/tools/word-tools.factor" run-resource ! inspector
"/library/platform/jvm/compiler.factor" run-resource ! compiler
"/library/platform/jvm/debugger.factor" run-resource ! debugger
-"/library/debugger.factor" run-resource ! debugger
+"/library/tools/debugger.factor" run-resource ! debugger
"/library/test/test.factor" run-resource ! test
"/library/platform/jvm/test.factor" run-resource ! test
"/library/ansi.factor" run-resource ! ansi
-"/library/telnetd.factor" run-resource ! telnetd
-"/library/inferior.factor" run-resource ! inferior
+"/library/tools/telnetd.factor" run-resource ! telnetd
+"/library/tools/inferior.factor" run-resource ! inferior
!!! Java -> native VM image cross-compiler.
-"/library/image.factor" run-resource ! cross-compiler
-"/library/cross-compiler.factor" run-resource ! cross-compiler
+"/library/tools/image.factor" run-resource ! cross-compiler
+"/library/tools/cross-compiler.factor" run-resource ! cross-compiler
"/library/platform/jvm/cross-compiler.factor" run-resource ! cross-compiler
-!!! HTTPD.
-"/library/httpd/url-encoding.factor" run-resource ! url-encoding
-"/library/httpd/html-tags.factor" run-resource ! html
-"/library/httpd/html.factor" run-resource ! html
-"/library/httpd/http-common.factor" run-resource ! httpd
-"/library/httpd/responder.factor" run-resource ! httpd-responder
-"/library/httpd/httpd.factor" run-resource ! httpd
-"/library/httpd/inspect-responder.factor" run-resource ! inspect-responder
-"/library/httpd/file-responder.factor" run-resource ! file-responder
-"/library/httpd/quit-responder.factor" run-resource ! quit-responder
-"/library/httpd/resource-responder.factor" run-resource ! resource-responder
-"/library/httpd/test-responder.factor" run-resource ! test-responder
-"/library/httpd/default-responders.factor" run-resource ! default-responders
-
!!! Final initialization...
"/library/init.factor" run-resource ! init
"/library/platform/jvm/init.factor" run-resource ! init
USE: continuations
USE: kernel
USE: lists
-USE: interpreter
+USE: listener
USE: namespaces
USE: parser
USE: stack
t "startup-done" set
- "interactive" get [ init-interpreter 1 exit* ] when ;
+ "interactive" get [ init-listener 1 exit* ] when ;
"/library/vocabulary-style.factor"
"/library/prettyprint.factor"
"/library/platform/native/debugger.factor"
- "/library/debugger.factor"
+ "/library/tools/debugger.factor"
"/library/platform/native/init.factor"
"/library/math/constants.factor"
"/library/platform/native/prettyprint.factor"
"/library/platform/native/files.factor"
"/library/files.factor"
- "/library/interpreter.factor"
- "/library/inspector.factor"
- "/library/inspect-vocabularies.factor"
+ "/library/tools/listener.factor"
+ "/library/tools/inspector.factor"
+ "/library/tools/word-tools.factor"
"/library/test/test.factor"
"/library/ansi.factor"
- "/library/telnetd.factor"
- "/library/inferior.factor"
+ "/library/tools/telnetd.factor"
+ "/library/tools/inferior.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/image.factor"
- "/library/cross-compiler.factor"
+ "/library/tools/image.factor"
+ "/library/tools/cross-compiler.factor"
"/library/platform/native/cross-compiler.factor"
"/library/httpd/url-encoding.factor"
DEFER: compilable-words
DEFER: compilable-word-list
-IN: init
-DEFER: init-interpreter
+IN: listener
+DEFER: init-listener
[
warm-boot
- "interactive" get [ init-interpreter ] when
+ "interactive" get [ init-listener ] when
0 exit*
] set-boot
--- /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) 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: telnetd
-USE: combinators
-USE: errors
-USE: interpreter
-USE: kernel
-USE: logging
-USE: logic
-USE: namespaces
-USE: stack
-USE: stdio
-USE: streams
-USE: threads
-
-: telnet-client ( socket -- )
- dup [
- "client" set
- log-client
- interpreter-loop
- ] with-stream ;
-
-: telnet-connection ( socket -- )
- #! We don't do multitasking in JFactor.
- java? [
- telnet-client
- ] [
- [ telnet-client ] in-thread drop
- ] ifte ;
-
-: quit-flag ( -- ? )
- global [ "telnetd-quit-flag" get ] bind ;
-
-: clear-quit-flag ( -- )
- global [ f "telnetd-quit-flag" set ] bind ;
-
-: telnetd-loop ( server -- server )
- quit-flag [
- dup >r accept telnet-connection r>
- telnetd-loop
- ] unless ;
-
-: telnetd ( port -- )
- [
- <server> [
- telnetd-loop
- ] [
- clear-quit-flag swap fclose rethrow
- ] catch
- ] with-logging ;
+++ /dev/null
-IN: scratchpad
-USE: arithmetic
-USE: combinators
-USE: compiler
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-USE: test
-
-"Checking association lists" print
-
-[
- [ "monkey" | 1 ]
- [ "banana" | 2 ]
- [ "Java" | 3 ]
- [ t | "true" ]
- [ f | "false" ]
- [ [ 1 2 ] | [ 2 1 ] ]
-] "assoc" set
-
-[ [ 1 1 0 0 ] ] [ [ assoc? ] ] [ balance>list ] test-word
-[ t ] [ "assoc" get ] [ assoc? ] test-word
-[ f ] [ [ 1 2 3 | 4 ] ] [ assoc? ] test-word
-
-[ [ 2 1 0 0 ] ] [ [ assoc ] ] [ balance>list ] test-word
-[ f ] [ "monkey" f ] [ assoc ] test-word
-[ f ] [ "donkey" "assoc" get ] [ assoc ] test-word
-[ 1 ] [ "monkey" "assoc" get ] [ assoc ] test-word
-[ "false" ] [ f "assoc" get ] [ assoc ] test-word
-[ [ 2 1 ] ] [ [ 1 2 ] "assoc" get ] [ assoc ] test-word
-
-"is great" "Java" "assoc" get set-assoc "assoc" set
-
-[ "is great" ] [ "Java" "assoc" get ] [ assoc ] test-word
--- /dev/null
+IN: scratchpad
+USE: test
+USE: inference
+USE: stack
+USE: combinators
+USE: vectors
+
+[ 6 ] [ 6 gensym-vector vector-length ] unit-test
+
+[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer ] unit-test
+[ [ 1 | 2 ] ] [ [ dup ] infer ] unit-test
+
+[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer ] unit-test
+[ [ call ] infer ] unit-test-fails
+
+[ [ 2 | 4 ] ] [ [ 2dup ] infer ] unit-test
+[ [ 2 | 0 ] ] [ [ set-vector-length ] infer ] unit-test
+[ [ 1 | 0 ] ] [ [ vector-clear ] infer ] unit-test
+[ [ 2 | 0 ] ] [ [ vector-push ] infer ] unit-test
+
+[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test
+[ [ ifte ] infer ] unit-test-fails
+[ [ [ ] ifte ] infer ] unit-test-fails
+[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails
+[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test
+
+[ [ 4 | 3 ] ] [
+ [
+ [
+ [ swap 3 ] [ nip 5 5 ] ifte
+ ] [
+ -rot
+ ] ifte
+ ] infer
+] unit-test
+++ /dev/null
-IN: scratchpad
-USE: interpreter
-USE: namespaces
-USE: stdio
-USE: test
-
-[
- [ 4 ] [ "2 2 +" eval-catch ] unit-test
- "The following will print an error; ignore it." print terpri
- [ ] [ "clear drop" eval-catch ] unit-test
-] with-scope
--- /dev/null
+IN: scratchpad
+USE: listener
+USE: namespaces
+USE: stdio
+USE: test
+
+[
+ [ 4 ] [ "2 2 +" eval-catch ] unit-test
+ "The following will print an error; ignore it." print terpri
+ [ ] [ "clear drop" eval-catch ] unit-test
+] with-scope
"image"
"init"
"inspector"
- "interpreter"
"io/io"
+ "listener"
"vectors"
"words"
"unparser"
"sbuf" test
"threads" test
"parsing-word" test
+ "inference" test
+ "interpreter" test
cpu "x86" = [
[
[ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test
[ t ] [ { 1 { 2 } 3 } hashcode { 1 { 2 } 3 } hashcode = ] unit-test
[ t ] [ { } hashcode { } hashcode = ] unit-test
+
+[ { 1 2 3 4 5 6 } ]
+[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test
--- /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: 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
+
+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
+ 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 ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or wxithout
+! 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: logic
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: strings
+USE: unparser
+
+: standard-dump ( error -- )
+ "ERROR: " write error. ;
+
+: parse-dump ( error -- )
+ <%
+ "error-file" get [ "<interactive>" ] unless* % ":" %
+ "error-line-number" get [ 1 ] unless* unparse % ": " %
+ %> write
+ error.
+
+ "error-line" get print
+
+ <% "error-col" get " " fill % "^" % %> print ;
+
+: in-parser? ( -- ? )
+ "error-line" get "error-col" get and ;
+
+: error-handler-hook
+ #! The game overrides this.
+ ;
+
+: default-error-handler ( error -- )
+ #! Print the error and return to the top level.
+ [
+ in-parser? [ parse-dump ] [ standard-dump ] ifte
+
+ ":s :r :n :c show stacks at time of error." print
+
+ java? [ ":j shows Java stack trace." print ] when
+ error-handler-hook
+
+ ] when* ;
+
+: :s ( -- ) "error-datastack" get {.} ;
+: :r ( -- ) "error-callstack" get {.} ;
+: :n ( -- ) "error-namestack" get {.} ;
+: :c ( -- ) "error-catchstack" get {.} ;
--- /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
+
+ ,] ' ;
+
+: (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=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: inference
+USE: combinators
+USE: errors
+USE: interpreter
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: vectors
+USE: words
+
+! Word properties that affect inference:
+! - infer-effect -- must be set. controls number of inputs
+! expected, and number of outputs produced.
+! - meta-infer -- evaluate word in meta-interpreter if set.
+! - infer - quotation with custom inference behavior; ifte uses
+! this. Word is passed on the stack.
+
+SYMBOL: d-in
+SYMBOL: r-in
+
+: gensym-vector ( n -- vector )
+ dup <vector> swap [ gensym over vector-push ] times ;
+
+: inputs ( count stack -- stack )
+ #! Add this many inputs to the given stack.
+ >r dup d-in +@ gensym-vector dup r> vector-append ;
+
+: ensure ( count stack -- stack )
+ #! Ensure stack has this many elements.
+ 2dup vector-length > [
+ [ vector-length - ] keep inputs
+ ] [
+ nip
+ ] ifte ;
+
+: ensure-d ( count -- )
+ #! Ensure count of unknown results are on the stack.
+ meta-d get ensure meta-d set ;
+
+: consume-d ( count -- )
+ #! Remove count of elements.
+ [ pop-d drop ] times ;
+
+: produce-d ( count -- )
+ #! Push count of unknown results.
+ [ gensym push-d ] times ;
+
+: standard-effect ( word [ in | out ] -- )
+ over "meta-infer" word-property [
+ drop host-word
+ ] [
+ unswons consume-d produce-d drop
+ ] ifte ;
+
+: apply-effect ( word [ in | out ] -- )
+ #! Helper word for apply-word.
+ dup car ensure-d
+ over "infer" word-property dup [
+ nip nip call
+ ] [
+ drop standard-effect
+ ] ifte ;
+
+: no-effect ( word -- )
+ "Unknown stack effect: " swap word-name cat2 throw ;
+
+DEFER: (infer)
+
+: apply-word ( word -- )
+ #! Apply the word's stack effect to the inferencer's state.
+ dup "infer-effect" word-property dup [
+ apply-effect
+ ] [
+ drop dup compound? [
+ word-parameter (infer)
+ ] [
+ drop no-effect
+ ] ifte
+ ] ifte ;
+
+: init-inference ( -- )
+ init-interpreter
+ 0 d-in set
+ 0 r-in set ;
+
+: effect ( -- [ in | out ] )
+ #! After inference is finished, collect information.
+ d-in get meta-d get vector-length cons ;
+
+: (infer) ( quot -- )
+ [ dup word? [ apply-word ] [ push-d ] ifte ] each ;
+
+: infer ( quot -- [ in | out ] )
+ #! Stack effect of a quotation.
+ [ init-inference (infer) effect ] with-scope ;
+
+: infer-branch ( quot -- in-d datastack )
+ [
+ copy-interpreter (infer)
+ d-in get meta-d get
+ ] with-scope ;
+
+: unify ( in stack in stack -- )
+ swapd 2dup vector-length= [
+ drop meta-d set
+ 2dup = [
+ drop d-in set
+ ] [
+ "Unbalanced ifte inputs" throw
+ ] ifte
+ ] [
+ "Unbalanced ifte outputs" throw
+ ] ifte ;
+
+: infer-ifte ( -- )
+ pop-d pop-d pop-d drop ( condition )
+ >r infer-branch r> infer-branch unify ;
+
+\ call [ pop-d (infer) ] "infer" set-word-property
+\ call [ 1 | 0 ] "infer-effect" set-word-property
+
+\ ifte [ 3 | 0 ] "infer-effect" set-word-property
+\ ifte [ infer-ifte ] "infer" set-word-property
+
+\ >r [ pop-d push-r ] "infer" set-word-property
+\ >r [ 1 | 0 ] "infer-effect" set-word-property
+\ r> [ pop-r push-d ] "infer" set-word-property
+\ r> [ 0 | 1 ] "infer-effect" set-word-property
+
+\ drop t "meta-infer" set-word-property
+\ drop [ 1 | 0 ] "infer-effect" set-word-property
+\ nip t "meta-infer" set-word-property
+\ nip [ 2 | 1 ] "infer-effect" set-word-property
+\ dup t "meta-infer" set-word-property
+\ dup [ 1 | 2 ] "infer-effect" set-word-property
+\ over t "meta-infer" set-word-property
+\ over [ 2 | 3 ] "infer-effect" set-word-property
+\ pick t "meta-infer" set-word-property
+\ pick [ 3 | 4 ] "infer-effect" set-word-property
+\ swap t "meta-infer" set-word-property
+\ swap [ 2 | 2 ] "infer-effect" set-word-property
+\ rot t "meta-infer" set-word-property
+\ rot [ 3 | 3 ] "infer-effect" set-word-property
+
+\ vector-nth [ 2 | 1 ] "infer-effect" set-word-property
+\ set-vector-nth [ 3 | 0 ] "infer-effect" set-word-property
+\ vector-length [ 1 | 1 ] "infer-effect" set-word-property
+\ set-vector-length [ 2 | 0 ] "infer-effect" set-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: inferior
+USE: combinators
+USE: errors
+USE: listener
+USE: kernel
+USE: lists
+USE: logic
+USE: namespaces
+USE: parser
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+USE: presentation
+
+! The purpose of this library is to allow CFactor to be embedded
+! inside the Java Factor listener in jEdit.
+!
+! Eg, in Java Factor, you could evaluate this after fixing the
+! paths accordingly:
+!
+! : (inf
+! [
+! "/home/slava/Factor/f"
+! "/home/slava/Factor/factor.image"
+! "-no-ansi"
+! ] pipe inferior-client ;
+!
+! Details:
+!
+! Packets have the following form:
+! 1 byte -- type. CHAR: w: write, CHAR: r: read
+! 4 bytes -- for write only -- length of write request
+! remaining -- unparsed write request -- string then style
+
+! After a read line request, the server reads a response from
+! the client:
+! 4 bytes -- length. -1 means EOF
+! remaining -- input
+
+! All multi-byte integers are big endian signed.
+
+: inferior-server-read ( -- str )
+ CHAR: r write flush read-big-endian-32 read# ;
+
+: inferior-server-write-attr ( str style -- )
+ CHAR: w write
+ [ swap . . ] with-string
+ dup str-length write-big-endian-32
+ write ;
+
+: inferior-server-flush ( -- )
+ CHAR: f write flush ;
+
+: <inferior-server-stream> ( stream -- stream )
+ <extend-stream> [
+ ( -- str )
+ [ inferior-server-read ] "freadln" set
+ ( str -- )
+ [
+ default-style inferior-server-write-attr
+ ] "fwrite" set
+ ( str style -- )
+ [ inferior-server-write-attr ] "fwrite-attr" set
+ ( string -- )
+ [
+ "\n" cat2 default-style inferior-server-write-attr
+ ] "fprint" set
+ ( -- )
+ [ inferior-server-flush ] "fflush" set
+ ] extend ;
+
+: inferior-client-read ( stream -- ? )
+ freadln dup [
+ dup str-length write-big-endian-32 write flush t
+ ] [
+ drop 0 write-big-endian-32 flush f
+ ] ifte ;
+
+: inferior-client-write ( stream -- ? )
+ read-big-endian-32 read# dup [
+ parse dup [
+ uncons car rot fwrite-attr t
+ ] [
+ 2drop f
+ ] ifte
+ ] when ;
+
+: inferior-client-packet ( stream -- ? )
+ #! Read from an inferior client socket and print attributed
+ #! strings that were read to standard output.
+ read1 [
+ [ not ] [ 2drop f ( EOF ) ]
+ [ CHAR: r = ] [ drop inferior-client-read ]
+ [ CHAR: w = ] [ drop inferior-client-write ]
+ [ CHAR: f = ] [ drop fflush t ]
+ [ drop t ] [ "Invalid packet type: " swap cat2 throw ]
+ ] cond ;
+
+: inferior-client-loop ( stream -- )
+ #! The stream is the stream to write to.
+ dup inferior-client-packet [
+ inferior-client-loop
+ ] [
+ drop
+ ] ifte ;
+
+: inferior-server ( -- )
+ #! Execute this in the inferior Factor.
+ terpri
+ "inferior-ack" print flush
+ "stdio" get <inferior-server-stream> "stdio" set ;
+
+: inferior-read-ack ( -- )
+ read [
+ "inferior-ack" = [ inferior-read-ack ] unless
+ ] when* ;
+
+: inferior-client ( from -- )
+ #! Execute this in the superior Factor, with a socket to
+ #! the inferior Factor as a parameter.
+ "stdio" get swap [
+ "USE: inferior inferior-server" print flush
+ inferior-read-ack
+ inferior-client-loop
+ ] with-stream ;
--- /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: inspector
+USE: combinators
+USE: format
+USE: kernel
+USE: hashtables
+USE: lists
+USE: namespaces
+USE: stack
+USE: stdio
+USE: strings
+USE: presentation
+USE: words
+USE: prettyprint
+USE: unparser
+USE: vectors
+
+: relative>absolute-object-path ( string -- string )
+ "object-path" get [ "'" rot cat3 ] when* ;
+
+: vars. ( -- )
+ #! Print a list of defined variables.
+ vars [ print ] each ;
+
+: object-actions ( -- alist )
+ [
+ [ "Describe" | "describe-path" ]
+ [ "Push" | "lookup" ]
+ ] ;
+
+: link-style ( path -- style )
+ relative>absolute-object-path
+ dup "object-link" swons swap
+ object-actions <actions> "actions" swons
+ t "underline" swons
+ 3list
+ default-style append ;
+
+: var. ( [ name | value ] -- )
+ uncons unparse swap link-style write-attr ;
+
+: var-name. ( max name -- )
+ tuck unparse pad-string write dup link-style
+ swap unparse swap write-attr ;
+
+: value. ( max name value -- )
+ >r var-name. ": " write r> . ;
+
+: name-padding ( alist -- col )
+ [ car unparse ] map max-str-length ;
+
+: describe-assoc ( alist -- )
+ dup name-padding swap
+ [ dupd uncons value. ] each drop ;
+
+: alist-sort ( list -- list )
+ [ swap car unparse swap car unparse str-lexi> ] sort ;
+
+: describe-namespace ( namespace -- )
+ [ vars-values ] bind alist-sort describe-assoc ;
+
+: describe-hashtable ( hashtables -- )
+ hash>alist alist-sort describe-assoc ;
+
+: describe ( obj -- )
+ [
+ [ word? ]
+ [ see ]
+
+ [ string? ]
+ [ print ]
+
+ [ assoc? ]
+ [ describe-assoc ]
+
+ [ has-namespace? ]
+ [ describe-namespace ]
+
+ [ hashtable? ]
+ [ describe-hashtable ]
+
+ [ drop t ]
+ [ prettyprint ]
+ ] cond ;
+
+: lookup ( str -- object )
+ global [ "'" split object-path ] bind ;
+
+: describe-path ( string -- )
+ [ dup "object-path" set lookup describe ] 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: interpreter
+USE: vectors
+USE: namespaces
+USE: logic
+USE: kernel
+USE: combinators
+USE: lists
+USE: words
+USE: stack
+USE: errors
+USE: continuations
+USE: strings
+USE: prettyprint
+USE: stdio
+
+! A Factor interpreter written in Factor. Used by compiler for
+! partial evaluation, also for trace and step.
+
+! Meta-stacks
+SYMBOL: meta-r
+: push-r meta-r get vector-push ;
+: pop-r meta-r get vector-pop ;
+SYMBOL: meta-d
+: push-d meta-d get vector-push ;
+: pop-d meta-d get vector-pop ;
+SYMBOL: meta-n
+SYMBOL: meta-c
+
+! Call frame
+SYMBOL: meta-cf
+
+: init-interpreter ( -- )
+ 10 <vector> meta-r set
+ 10 <vector> meta-d set
+ 10 <vector> meta-n set
+ 10 <vector> meta-c set
+ f meta-cf set ;
+
+: copy-interpreter ( -- )
+ #! Copy interpreter state from containing namespaces.
+ meta-r get vector-clone meta-r set
+ meta-d get vector-clone meta-d set
+ meta-n get vector-clone meta-n set
+ meta-c get vector-clone meta-c set ;
+
+: done-cf? ( -- ? )
+ meta-cf get not ;
+
+: done? ( -- ? )
+ done-cf? meta-r get vector-empty? and ;
+
+! Callframe.
+: up ( -- )
+ pop-r meta-cf set ;
+
+: next ( -- obj )
+ meta-cf get [ meta-cf uncons@ ] [ up next ] ifte ;
+
+: host-word ( word -- )
+ #! Swap in the meta-interpreter's stacks, execute the word,
+ #! swap in the old stacks. This is so messy.
+ push-d datastack push-d
+ meta-d get set-datastack
+ >r execute datastack r> tuck vector-push
+ set-datastack meta-d set ;
+
+: meta-call ( quot -- )
+ #! Note we do tail call optimization here.
+ meta-cf get [ push-r ] when* meta-cf set ;
+
+: meta-word ( word -- )
+ dup "meta-word" word-property dup [
+ nip call
+ ] [
+ drop dup compound? [
+ word-parameter meta-call
+ ] [
+ host-word
+ ] ifte
+ ] ifte ;
+
+: do ( obj -- )
+ dup word? [ meta-word ] [ push-d ] ifte ;
+
+: (interpret) ( quot -- )
+ #! The quotation is called with each word as its executed.
+ done? [ drop ] [ [ next swap call ] keep (interpret) ] ifte ;
+
+: interpret ( quot quot -- )
+ #! The first quotation is meta-interpreted, with each word
+ #! passed to the second quotation. Pollutes current
+ #! namespace.
+ init-interpreter swap meta-cf set (interpret) ;
+
+: (run) ( -- )
+ [ do ] (interpret) ;
+
+: run ( quot -- )
+ [ do ] interpret ;
+
+: set-meta-word ( word quot -- )
+ "meta-word" set-word-property ;
+
+\ datastack [ meta-d get vector-clone push-d ] set-meta-word
+\ set-datastack [ pop-d vector-clone meta-d set ] set-meta-word
+\ >r [ pop-d push-r ] set-meta-word
+\ r> [ pop-r push-d ] set-meta-word
+\ callstack [ meta-r get vector-clone push-d ] set-meta-word
+\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word
+\ namestack* [ meta-n get push-d ] set-meta-word
+\ set-namestack* [ pop-d meta-n set ] set-meta-word
+\ catchstack* [ meta-c get push-d ] set-meta-word
+\ set-catchstack* [ pop-d meta-c set ] set-meta-word
+\ call [ pop-d meta-call ] set-meta-word
+\ execute [ pop-d meta-word ] set-meta-word
+\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
+
+! Some useful tools
+
+: report ( obj -- )
+ meta-r get vector-length " " fill write . flush ;
+
+: (trace) ( -- )
+ [ dup report do ] (interpret) ;
+
+: trace ( quot -- )
+ #! Trace execution of a quotation by printing each word as
+ #! its executed, and each literal as its pushed. Each line
+ #! is indented by the call stack height.
+ [
+ init-interpreter
+ meta-cf set
+ (trace)
+ meta-d get set-datastack
+ ] with-scope ;
+
+: walk-banner ( -- )
+ "The following words control the single-stepper:" print
+ "&s -- print stepper data stack" print
+ "&r -- print stepper call stack" print
+ "&n -- print stepper name stack" print
+ "&c -- print stepper catch stack" print
+ "step -- single step" print
+ "(trace) -- trace until end" print
+ "(run) -- run until end" print ;
+
+: walk ( quot -- )
+ #! Single-step through execution of a quotation.
+ init-interpreter
+ meta-cf set
+ walk-banner ;
+
+: &s
+ #! Print stepper data stack.
+ meta-d get {.} ;
+
+: &r
+ #! Print stepper call stack.
+ meta-r get {.} meta-cf get . ;
+
+: &n
+ #! Print stepper name stack.
+ meta-n get {.} ;
+
+: &c
+ #! Print stepper catch stack.
+ meta-c get {.} ;
+
+: not-done ( quot -- )
+ done? [ "Stepper is done." print drop ] [ call ] ifte ;
+
+: step
+ #! Step into current word.
+ [ next dup report do ] not-done ;
--- /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: listener
+USE: combinators
+USE: continuations
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: parser
+USE: stack
+USE: stdio
+USE: strings
+USE: presentation
+USE: words
+USE: unparser
+USE: vectors
+
+: print-banner ( -- )
+ <% "This is " % java? [ "JVM " % ] when
+ native? [ "native " % ] when "Factor " % version % %> print
+ "Copyright (C) 2003, 2004 Slava Pestov" print
+ "Copyright (C) 2004 Chris Double" print
+ "Type ``exit'' to exit, ``help'' for help." print ;
+
+: print-prompt ( -- )
+ "ok" "prompt" style write-attr
+ ! Print the space without a style, to workaround a bug in
+ ! the GUI listener where the style from the prompt carries
+ ! over to the input
+ " " write flush ;
+
+: exit ( -- )
+ "quit-flag" on ;
+
+: eval-catch ( str -- )
+ [ eval ] [ [ default-error-handler drop ] when* ] catch ;
+
+: listener-step ( -- )
+ print-prompt read [ eval-catch ] [ exit ] ifte* ;
+
+: listener-loop ( -- )
+ "quit-flag" get [
+ "quit-flag" off
+ ] [
+ listener-step listener-loop
+ ] ifte ;
+
+: room. ( -- )
+ room
+ 1024 /i unparse write " KB total, " write
+ 1024 /i unparse write " KB free" print ;
+
+: init-listener ( -- )
+ print-banner
+ room.
+
+ listener-loop ;
+
+: help ( -- )
+ "SESSION:" print
+ native? [
+ "\"foo.image\" save-image -- save heap to a file" print
+ ] when
+ "room. -- show memory usage" print
+ "heap-stats. -- memory allocation breakdown" print
+ "garbage-collection -- force a GC" print
+ "exit -- exit interpreter" print
+ terpri
+ "WORDS:" print
+ "vocabs. -- list vocabularies" print
+ "\"math\" words. -- list the math vocabulary" print
+ "\"str\" apropos. -- list all words containing str" print
+ "\\ neg see -- show word definition" print
+ "\\ car usages. -- list all words invoking car" print
+ terpri
+ "STACKS:" print
+ ".s .r .n .c -- show contents of the 4 stacks" print
+ "clear -- clear datastack" print
+ terpri
+ "OBJECTS:" print
+ "global describe -- list global variables." print
+ "\"foo\" get . -- print a variable value." print
+ ". -- print top of stack." print
+ terpri
+ "PROFILER: [ ... ] call-profile" print
+ " [ ... ] allot-profile" print
+ "TRACE: [ ... ] trace" print
+ "SINGLE STEP: [ ... ] step" print
+ terpri
+ "HTTP SERVER: USE: httpd 8888 httpd" print
+ "TELNET SERVER: USE: telnetd 9999 telnetd" print ;
--- /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: telnetd
+USE: combinators
+USE: errors
+USE: listener
+USE: kernel
+USE: logging
+USE: logic
+USE: namespaces
+USE: stack
+USE: stdio
+USE: streams
+USE: threads
+
+: telnet-client ( socket -- )
+ dup [
+ "client" set
+ log-client
+ listener-loop
+ ] with-stream ;
+
+: telnet-connection ( socket -- )
+ #! We don't do multitasking in JFactor.
+ java? [
+ telnet-client
+ ] [
+ [ telnet-client ] in-thread drop
+ ] ifte ;
+
+: quit-flag ( -- ? )
+ global [ "telnetd-quit-flag" get ] bind ;
+
+: clear-quit-flag ( -- )
+ global [ f "telnetd-quit-flag" set ] bind ;
+
+: telnetd-loop ( server -- server )
+ quit-flag [
+ dup >r accept telnet-connection r>
+ telnetd-loop
+ ] unless ;
+
+: telnetd ( port -- )
+ [
+ <server> [
+ telnetd-loop
+ ] [
+ clear-quit-flag swap fclose rethrow
+ ] catch
+ ] with-logging ;
--- /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: words
+USE: combinators
+USE: inspector
+USE: lists
+USE: kernel
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: strings
+USE: unparser
+
+: word-uses? ( of in -- ? )
+ 2dup = [
+ 2drop f ! Don't say that a word uses itself
+ ] [
+ word-parameter tree-contains?
+ ] ifte ;
+
+: usages-in-vocab ( of vocab -- usages )
+ #! Push a list of all usages of a word in a vocabulary.
+ words [
+ dup compound? [
+ dupd word-uses?
+ ] [
+ drop f ! Ignore words without a definition
+ ] ifte
+ ] subset nip ;
+
+: usages-in-vocab. ( of vocab -- )
+ #! List all usages of a word in a vocabulary.
+ tuck usages-in-vocab dup [
+ swap "IN: " write print [.]
+ ] [
+ 2drop
+ ] ifte ;
+
+: usages. ( word -- )
+ #! List all usages of a word in all vocabularies.
+ vocabs [ dupd usages-in-vocab. ] each drop ;
+
+: vocab-apropos ( substring vocab -- list )
+ #! Push a list of all words in a vocabulary whose names
+ #! contain a string.
+ words [ word-name dupd str-contains? ] subset nip ;
+
+: vocab-apropos. ( substring vocab -- )
+ #! List all words in a vocabulary that contain a string.
+ tuck vocab-apropos dup [
+ "IN: " write swap print [.]
+ ] [
+ 2drop
+ ] ifte ;
+
+: apropos. ( substring -- )
+ #! List all words that contain a string.
+ vocabs [ dupd vocab-apropos. ] each drop ;
+
+: in. ( -- )
+ #! Print the vocabulary where new words are added in
+ #! interactive parsers.
+ "in" get print ;
+
+: use. ( -- )
+ #! Print the vocabulary search path for interactive parsers.
+ "use" get . ;
+
+: vocabs. ( -- )
+ vocabs . ;
+
+: words. ( vocab -- )
+ words . ;
: vector-all? ( vector pred -- ? )
vector-map vector-and ;
+
+: vector-append ( v1 v2 -- )
+ #! Destructively append v2 to v1.
+ [ over vector-push ] vector-each drop ;
: vector-empty? ( obj -- ? )
vector-length 0 = ;
-: vector-clear ( vector -- list )
+: vector-clear ( vector -- )
#! Clears a vector.
0 swap set-vector-length ;
"files"
"hashtables"
"inferior"
- "inspector"
"interpreter"
+ "inspector"
"jedit"
"kernel"
+ "listener"
"lists"
"logic"
"math"
"parser"
"prettyprint"
"processes"
+ "profiler"
"stack"
"streams"
"stdio"
{
struct sockaddr_in clientname;
size_t size = sizeof(clientname);
-
- /* int oobinline = 1; */
int new = accept(p->fd,(struct sockaddr *)&clientname,&size);
if(new < 0)
io_error(__FUNCTION__);
}
- /* if(setsockopt(new,SOL_SOCKET,SO_OOBINLINE,&oobinline,sizeof(int)) < 0)
- io_error(__FUNCTION__); */
-
p->client_host = tag_object(from_c_string(inet_ntoa(
clientname.sin_addr)));
p->client_port = tag_fixnum(ntohs(clientname.sin_port));
projects / factor.git / commitdiff