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

working on cfactor bootstrap

cvs
Slava Pestov 2004-08-20 22:48:08 +00:00
parent 2fccd38742
commit 5b24e99fc9
31 changed files with 600 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO.FACTOR.txt
View File

@ -1,19 +1,21 @@
- input style after clicking link
- fedit broken with listener
- maple-like: press enter at old commands to evaluate there
- enforce bottom-up in native bootstrap
- fix up native file/line info
- standalone listener input style
- add a socket timeout
- drop test in http server
- jedit bug? +line doesn't always work when switching into an existing
buffer with a remembered first line
- jedit bug? ' in noWordSep ignored
- word names containing ' not quoted properly
- completion: enter no good
- completion: don't show automatically
- balance needs USE:
- postpone errors until actual read/write op
- command line arguments
- socket protocol
- irc: stack underflow?
+ docs:
@ -45,7 +47,6 @@
- gc call in the middle of some ops might affect callstack
- multitasking
- parsing should be parsing
- better error reporting
+ JVM compiler:

47
contrib/irc.factor
View File

@ -68,18 +68,21 @@ USE: unparser
: keep-datastack ( quot -- )
datastack [ call ] dip set-datastack drop ;
: irc-stream-write ( string -- )
dup "buf" get sbuf-append
ends-with-newline? [
"buf" get >str
0 "buf" get set-sbuf-length
"\n" split [ dup f-or-"" [ drop ] [ "recepient" get irc-message ] ifte ] each
] when ;
: <irc-stream> ( stream recepient -- stream )
<stream> [
"recepient" set
"stdio" set
100 <sbuf> "buf" set
[
dup "buf" get sbuf-append
ends-with-newline? [
"buf" get >str
0 "buf" get set-sbuf-length
"\n" split [ "recepient" get irc-message ] each
] when
irc-stream-write
] "fwrite" set
] extend ;
@ -100,15 +103,17 @@ USE: unparser
: irc-action-quot ( action -- quot )
[
[ "eval" irc-eval ]
[ "see" see terpri ]
] assoc [ [ drop ] ] unless* ;
[ "eval" swap [ irc-eval ] with-irc-stream ]
[ "see" swap [ see terpri ] with-irc-stream ]
[ "join" nip irc-join ]
[ "quit" 2drop global [ "irc-quit-flag" on ] bind ]
] assoc [ [ 2drop ] ] unless* ;
: irc-action-handler ( messag e -- )
: irc-action-handler ( recepient message -- )
" " split1 swap irc-action-quot call ;
: irc-handle-privmsg ( [ recepient message ] -- )
uncons car swap [ irc-action-handler ] with-irc-stream ;
uncons car irc-action-handler ;
: irc-handle-join ( [ joined channel ] -- )
uncons car
@ -130,13 +135,21 @@ USE: unparser
global [ print ] bind ;
: irc-quit-flag ( -- ? )
global [ "irc-quit-flag" get ] bind ;
: clear-irc-quit-flag ( -- ? )
global [ "irc-quit-flag" off ] bind ;
: irc-loop ( -- )
read [ irc-input irc-loop ] when* ;
irc-quit-flag [
read [ irc-input irc-loop ] when*
] unless clear-irc-quit-flag ;
: irc ( channels -- )
irc-register
dup [ irc-join ] each
[ "Hello everybody" swap irc-message ] each
! "identify foobar" "NickServ" irc-message
[ irc-join ] each
irc-loop ;
: irc-test
@ -145,8 +158,8 @@ USE: unparser
"irc.freenode.net" "server" set
"Factor" "realname" set
"factorbot" "nick" set
<namespace> "facts" set
"irc.freenode.net" 6667 <client>
<namespace> [ "stdio" set [ "#factor" ] irc ] bind ;
"irc.freenode.net" 6667 <client> [
[ "#factor" ] irc
] with-stream ;
!! "factor/irc.factor" run-file

2
factor/jedit/FactorWordRenderer.java
View File

@ -56,7 +56,7 @@ public class FactorWordRenderer extends DefaultListCellRenderer
String prop = "factor.completion.plain";
String stackEffect = null;
if(!value instanceof FactorWord)
if(!(value instanceof FactorWord))
return this;
FactorWord word = (FactorWord)value;

6
gcj-compile
View File

@ -1,6 +0,0 @@
#!/bin/sh
for file in `find org factor -name \*.java`; do
gcj -c $file
done
gcj --main=factor.FactorInterpreter -o f *.o

6
library/cross-compiler.factor
View File

@ -252,5 +252,7 @@ IN: cross-compiler
swap write-image ;
: make-images ( -- )
"big-endian" off "factor.image.le" make-image
"big-endian" on "factor.image.be" make-image ;
"big-endian" off "boot.image.le" make-image
"big-endian" on "boot.image.be" make-image
"boot.image.le and boot.image.be have been generated." print
;

1
library/image.factor
View File

@ -186,6 +186,7 @@ USE: words
nip
] [
drop
"Forward reference: " write dup .
! Remember where we are, and add the reference later
dup fixup-word-later
] ifte ;

44
library/init.factor
View File

@ -87,50 +87,6 @@ USE: words
#! Parse command line arguments.
parse-switches run-files ;
: init-search-path ( -- )
! For files
"user" "file-in" set
[ "user" "builtins" ] "file-use" set
! For interactive
"user" "in" set
[
"user"
"arithmetic"
"builtins"
"combinators"
"compiler"
"continuations"
"errors"
"debugger"
"hashtables"
"inspector"
"interpreter"
"jedit"
"kernel"
"lists"
"logic"
"math"
"namespaces"
"parser"
"prettyprint"
"stack"
"streams"
"stdio"
"strings"
"test"
"trace"
"unparser"
"vectors"
"vocabularies"
"words"
"scratchpad"
] "use" set ;
: init-scratchpad ( -- )
#! The contents of the scratchpad vocabulary is not saved
#! between runs.
<namespace> "scratchpad" "vocabularies" get set* ;
: init-toplevel ( -- )
[ "top-level-continuation" set ] callcc0 ;

1
library/platform/jvm/init.factor
View File

@ -39,6 +39,7 @@ USE: stack
USE: stdio
USE: streams
USE: strings
USE: words
: stdin ( -- stdin )
"java.lang.System" "in" jvar-static-get

34
library/platform/jvm/regexp.factor
View File

@ -34,7 +34,7 @@ USE: lists
USE: stack
: <regex> ( pattern -- regex )
! Compile the regex, if its not already compiled.
#! Compile the regex, if its not already compiled.
dup "java.util.regex.Pattern" is not [
[ "java.lang.String" ]
"java.util.regex.Pattern" "compile"
@ -54,10 +54,10 @@ USE: stack
<regex> <matcher> re-matches* ;
: [re-matches] ( matcher code -- boolean )
! If the matcher's re-matches* function returns true,
! evaluate the code with the matcher at the top of the
! stack. Otherwise, pop the matcher off the stack and
! push f.
#! If the matcher's re-matches* function returns true,
#! evaluate the code with the matcher at the top of the
#! stack. Otherwise, pop the matcher off the stack and
#! push f.
[ dup re-matches* ] dip [ drop f ] ifte ;
: re-replace* ( replace matcher -- string )
@ -65,8 +65,8 @@ USE: stack
"replaceAll" jinvoke ;
: re-replace ( input regex replace -- string )
! Replaces all occurrences of the regex in the input string
! with the replace string.
#! Replaces all occurrences of the regex in the input string
#! with the replace string.
-rot <regex> <matcher> re-replace* ;
: re-split ( string split -- list )
@ -95,23 +95,3 @@ USE: stack
: group1 ( string regex -- string )
groups dup [ car ] when ;
: groups/t ( string re -- groups )
dup t = [
nip
] [
groups
] ifte ;
: re-cond ( string alist -- )
dup [
unswons [ over ] dip ( string tail string head )
uncons [ groups/t ] dip ( string tail groups code )
over [
2nip call
] [
2drop re-cond
] ifte
] [
2drop
] ifte ;

131
library/platform/native/boot-stage2.factor Normal file
View File

@ -0,0 +1,131 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
USE: kernel
USE: lists
USE: parser
USE: stack
USE: stdio
"Cold boot in progress..." print
[
"/library/platform/native/kernel.factor"
"/library/platform/native/stack.factor"
"/library/cons.factor"
"/library/combinators.factor"
"/library/logic.factor"
"/library/platform/native/vectors.factor"
"/library/vector-combinators.factor"
"/library/lists.factor"
"/library/assoc.factor"
"/library/math/arithmetic.factor"
"/library/math/math-combinators.factor"
"/library/vectors.factor"
"/library/platform/native/strings.factor"
"/library/strings.factor"
"/library/hashtables.factor"
"/library/platform/native/namespaces.factor"
"/library/namespaces.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"
"/library/platform/native/errors.factor"
"/library/errors.factor"
"/library/stream.factor"
"/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor"
"/library/stdio.factor"
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
"/library/vocabularies.factor"
"/library/platform/native/parse-numbers.factor"
"/library/platform/native/parser.factor"
"/library/platform/native/parse-syntax.factor"
"/library/platform/native/parse-stream.factor"
"/library/platform/native/init.factor"
"/library/math/math.factor"
"/library/math/pow.factor"
"/library/math/trig-hyp.factor"
"/library/math/arc-trig-hyp.factor"
"/library/math/quadratic.factor"
"/library/math/list-math.factor"
"/library/math/simpson.factor"
"/library/platform/native/network.factor"
"/library/logging.factor"
"/library/platform/native/random.factor"
"/library/random.factor"
"/library/stdio-binary.factor"
"/library/platform/native/prettyprint.factor"
"/library/interpreter.factor"
"/library/inspector.factor"
"/library/inspect-vocabularies.factor"
"/library/test/test.factor"
"/library/ansi.factor"
"/library/telnetd.factor"
"/library/image.factor"
"/library/cross-compiler.factor"
"/library/platform/native/cross-compiler.factor"
"/library/httpd/url-encoding.factor"
"/library/httpd/html.factor"
"/library/httpd/http-common.factor"
"/library/httpd/responder.factor"
"/library/httpd/httpd.factor"
"/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor"
"/library/httpd/quit-responder.factor"
"/library/httpd/default-responders.factor"
"/library/jedit/jedit-no-local.factor"
"/library/jedit/jedit-remote.factor"
"/library/jedit/jedit.factor"
"/library/init.factor"
"/library/platform/native/init-stage2.factor"
] [
dup print
run-resource
] each
IN: init
DEFER: finish-cold-boot
DEFER: warm-boot
finish-cold-boot
: set-boot ( quot -- ) 8 setenv ;
[ warm-boot ] set-boot
garbage-collection
"factor.image" save-image
0 exit*

109
library/platform/native/boot.factor
View File

@ -25,101 +25,53 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USE: arithmetic
USE: combinators
USE: format
USE: inspector
USE: init
USE: kernel
USE: lists
USE: logic
USE: math
USE: namespaces
USE: stack
USE: stdio
USE: streams
USE: strings
USE: vectors
USE: words
USE: cross-compiler
primitives,
[
"/library/ansi.factor"
"/library/assoc.factor"
"/library/cross-compiler.factor"
"/library/combinators.factor"
"/library/platform/native/kernel.factor"
"/library/platform/native/stack.factor"
"/library/cons.factor"
"/library/continuations.factor"
"/library/debugger.factor"
"/library/errors.factor"
"/library/format.factor"
"/library/hashtables.factor"
"/library/image.factor"
"/library/init.factor"
"/library/inspector.factor"
"/library/inspect-vocabularies.factor"
"/library/interpreter.factor"
"/library/lists.factor"
"/library/list-namespaces.factor"
"/library/logging.factor"
"/library/combinators.factor"
"/library/logic.factor"
"/library/namespaces.factor"
"/library/prettyprint.factor"
"/library/random.factor"
"/library/sbuf.factor"
"/library/stdio.factor"
"/library/stdio-binary.factor"
"/library/stream.factor"
"/library/strings.factor"
"/library/styles.factor"
"/library/telnetd.factor"
"/library/vectors.factor"
"/library/platform/native/vectors.factor"
"/library/vector-combinators.factor"
"/library/vocabularies.factor"
"/library/vocabulary-style.factor"
"/library/words.factor"
"/library/httpd/html.factor"
"/library/httpd/url-encoding.factor"
"/library/httpd/http-common.factor"
"/library/httpd/responder.factor"
"/library/httpd/httpd.factor"
"/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor"
"/library/httpd/quit-responder.factor"
"/library/httpd/default-responders.factor"
"/library/jedit/jedit-remote.factor"
"/library/jedit/jedit-no-local.factor"
"/library/jedit/jedit.factor"
"/library/math/arc-trig-hyp.factor"
"/library/lists.factor"
"/library/assoc.factor"
"/library/math/arithmetic.factor"
"/library/math/list-math.factor"
"/library/math/math.factor"
"/library/math/math-combinators.factor"
"/library/vectors.factor"
"/library/platform/native/strings.factor"
"/library/strings.factor"
"/library/hashtables.factor"
"/library/platform/native/namespaces.factor"
"/library/namespaces.factor"
"/library/math/namespace-math.factor"
"/library/math/pow.factor"
"/library/math/quadratic.factor"
"/library/math/trig-hyp.factor"
"/library/math/simpson.factor"
"/library/test/test.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"
"/library/platform/native/errors.factor"
"/library/errors.factor"
"/library/stream.factor"
"/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor"
"/library/platform/native/namespaces.factor"
"/library/platform/native/strings.factor"
"/library/stdio.factor"
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
"/library/vocabularies.factor"
"/library/platform/native/parse-numbers.factor"
"/library/platform/native/parser.factor"
"/library/platform/native/parse-syntax.factor"
"/library/platform/native/parse-stream.factor"
"/library/platform/native/prettyprint.factor"
"/library/platform/native/random.factor"
"/library/platform/native/stack.factor"
"/library/platform/native/words.factor"
"/library/platform/native/vectors.factor"
"/library/platform/native/kernel.factor"
"/library/platform/native/vocabularies.factor"
"/library/platform/native/unparser.factor"
"/library/platform/native/cross-compiler.factor"
"/library/format.factor"
"/library/styles.factor"
"/library/vocabulary-style.factor"
"/library/prettyprint.factor"
"/library/debugger.factor"
"/library/platform/native/debugger.factor"
"/library/platform/native/init.factor"
] [
cross-compile-resource
@ -127,4 +79,7 @@ primitives,
version,
[ boot ] (set-boot)
IN: init
DEFER: cold-boot
[ cold-boot ] (set-boot)

2
library/platform/native/cross-compiler.factor
View File

@ -32,6 +32,6 @@ USE: parser
: cross-compile-resource ( resource -- )
[
! Change behavior of ;
"cross-compiling" on
[ compound, ] ";-hook" set
run-resource
] with-scope ;

75
library/platform/native/debugger.factor Normal file
View File

@ -0,0 +1,75 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: errors
USE: arithmetic
USE: combinators
USE: continuations
USE: kernel
USE: lists
USE: logic
USE: namespaces
USE: prettyprint
USE: stack
USE: stdio
USE: strings
USE: unparser
USE: vectors
: kernel-error? ( obj -- ? )
dup cons? [ car fixnum? ] [ drop f ] ifte ;
: ?vector-nth ( n vec -- obj )
over [
dup >r vector-length min 0 max r> vector-nth
] [
2drop f
] ifte ;
: error# ( n -- str )
{
"Expired port: "
"Undefined word: "
"Type check: "
"Array range check: "
"Underflow"
"I/O error: "
"Overflow"
"Incomparable types: "
"Float format: "
"Signal "
} ?vector-nth ;
: ?kernel-error ( cons -- error# param )
dup cons? [ uncons dup cons? [ car ] when ] [ f ] ifte ;
: kernel-error. ( error -- )
?kernel-error swap error# dup "" ? write
dup [ . ] [ drop terpri ] ifte ;
: error. ( error -- str )
dup kernel-error? [ kernel-error. ] [ . ] ifte ;

46
library/platform/native/errors.factor
View File

@ -26,18 +26,7 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: errors
USE: arithmetic
USE: combinators
USE: continuations
USE: kernel
USE: lists
USE: logic
USE: namespaces
USE: prettyprint
USE: stack
USE: stdio
USE: strings
USE: unparser
USE: vectors
! This is a very lightweight exception handling system.
@ -47,43 +36,8 @@ USE: vectors
: set-catchstack* ( cs -- ) 6 setenv ;
: set-catchstack ( cs -- ) clone set-catchstack* ;
: kernel-error? ( obj -- ? )
dup cons? [ car fixnum? ] [ drop f ] ifte ;
: ?vector-nth ( n vec -- obj )
over [
dup >r vector-length min 0 max r> vector-nth
] [
2drop f
] ifte ;
: error# ( n -- str )
{
"Expired port: "
"Undefined word: "
"Type check: "
"Array range check: "
"Underflow"
"I/O error: "
"Overflow"
"Incomparable types: "
"Float format: "
"Signal "
} ?vector-nth ;
: ?kernel-error ( cons -- error# param )
dup cons? [ uncons dup cons? [ car ] when ] [ f ] ifte ;
: kernel-error. ( error -- )
?kernel-error swap error# dup "" ? write
dup [ . ] [ drop terpri ] ifte ;
: error. ( error -- str )
dup kernel-error? [ kernel-error. ] [ . ] ifte ;
DEFER: >c
DEFER: throw
DEFER: default-error-handler
: init-errors ( -- )
64 <vector> set-catchstack*

66
library/platform/native/init-stage2.factor Normal file
View File

@ -0,0 +1,66 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
USE: ansi
USE: combinators
USE: errors
USE: httpd-responder
USE: kernel
USE: namespaces
USE: parser
USE: random
USE: streams
USE: styles
USE: words
: warm-boot ( -- )
#! A fully bootstrapped image has this as the boot
#! quotation.
boot
init-random
"stdio" get <ansi-stream> "stdio" set
! Some flags are *on* by default, unless user specifies
! -no-<flag> CLI switch
t "user-init" set
t "interactive" set
run-user-init
"interactive" get [ init-interpreter ] when
0 exit* ;
: finish-cold-boot ( -- )
#! After the stage2 bootstrap is done, this word
#! completes initialization.
init-scratchpad
init-styles
init-vocab-styles
default-responders ;

52
library/platform/native/init.factor
View File

@ -26,58 +26,32 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
USE: ansi
USE: arithmetic
USE: errors
USE: combinators
USE: hashtables
USE: httpd-responder
USE: errors
USE: kernel
USE: lists
USE: logic
USE: interpreter
USE: io-internals
USE: math
USE: random
USE: namespaces
USE: parser
USE: prettyprint
USE: stack
USE: stdio
USE: streams
USE: strings
USE: styles
USE: vectors
USE: words
USE: unparser
: init-gc ( -- )
[ garbage-collection ] 7 setenv ;
: boot ( -- )
#! Initialize an interpreter with the basic services.
init-gc
init-random
init-namespaces
init-stdio
"stdio" get <ansi-stream> "stdio" set
! Some flags are *on* by default, unless user specifies
! -no-<flag> CLI switch
t "user-init" set
t "interactive" set
"HOME" os-env [ "." ] unless* "~" set
"/" "/" set
10 "base" set
init-errors
init-search-path
init-scratchpad
init-styles
init-vocab-styles
default-responders
run-user-init
"interactive" get [ init-interpreter ] when
0 exit* ;
"HOME" os-env [ "." ] unless* "~" set
10 "base" set
"/" "/" set
init-search-path ;
: cold-boot ( -- )
#! An initially-generated image has this as the boot
#! quotation.
boot
"/library/platform/native/boot-stage2.factor" run-resource
"finish-cold-boot" [ "init" ] search execute ;

7
library/platform/native/kernel.factor
View File

@ -28,6 +28,12 @@
IN: namespaces
DEFER: init-namespaces
IN: vectors
DEFER: vector=
IN: errors
DEFER: init-errors
IN: kernel
USE: arithmetic
USE: combinators
@ -42,6 +48,7 @@ USE: strings
USE: vectors
USE: words
USE: unparser
USE: vectors
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.

61
library/platform/native/network.factor Normal file
View File

@ -0,0 +1,61 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: streams
USE: combinators
USE: continuations
USE: io-internals
USE: errors
USE: kernel
USE: logic
USE: stack
USE: stdio
USE: strings
USE: namespaces
USE: unparser
: <server> ( port -- stream )
#! Starts listening on localhost:port. Returns a stream that
#! you can close with fclose, and accept connections from
#! with accept. No other stream operations are supported.
server-socket <stream> [
"socket" set
( -- )
[ "socket" get close-fd ] "fclose" set
] extend ;
: <client-stream> ( host port in out -- stream )
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
: <client> ( host port -- stream )
#! fflush yields until connection is established.
2dup client-socket <client-stream> dup fflush ;
: accept ( server -- client )
#! Accept a connection from a server socket.
"socket" swap get* blocking-accept <client-stream> ;

15
library/platform/native/parse-syntax.factor
View File

@ -77,11 +77,13 @@ USE: unparser
#! Begin a word definition. Word name follows.
CREATE dup remember-where [ ] ; parsing
: ;-hook ( -- quot )
";-hook" get [ [ define-compound ] ] unless* ;
: ;
#! End a word definition.
nreverse
"cross-compiling" get
[ compound, ] [ define-compound ] ifte ; parsing
;-hook call ; parsing
! Vocabularies
: DEFER: CREATE drop ; parsing
@ -116,14 +118,16 @@ USE: unparser
ascii-escape>ch
] ifte ;
! String literal
: parse-escape ( -- )
next-ch escape dup [ drop "Bad escape" throw ] unless ;
: parse-ch ( ch -- ch )
dup CHAR: \\ = [ drop parse-escape ] when ;
! Char literal
: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
! String literal
: parse-string ( -- )
next-ch dup CHAR: " = [
drop
@ -136,9 +140,6 @@ USE: unparser
#! the <% %> scope up to the original scope.
<% parse-string "col" get %> swap "col" set parsed ; parsing
! Char literal
: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
! Complex literal
: #{
#! Read #{ real imaginary #}

12
library/platform/native/parser.factor
View File

@ -56,9 +56,10 @@ USE: unparser
] ifte ;
: parsing ( -- )
"cross-compiling" get [
t "parsing" word set-word-property
] unless ; parsing
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
t "parsing" word set-word-property ;
: <parsing "line" set 0 "col" set ;
: parsing> "line" off "col" off ;
@ -171,3 +172,8 @@ USE: unparser
: next-word-ch ( -- ch )
"col" get "line" get skip-blank "col" set next-ch ;
! Once this file has loaded, we can use 'parsing' normally.
! This hack is needed because in Java Factor, 'parsing' is
! not parsing, but in CFactor, it is.
t "parsing" "parsing" [ "parser" ] search set-word-property

23
library/platform/native/stream.factor
View File

@ -36,7 +36,6 @@ USE: stack
USE: stdio
USE: strings
USE: namespaces
USE: unparser
: <fd-stream> ( in out -- stream )
#! Create a file descriptor stream object, wrapping a pair
@ -78,28 +77,6 @@ USE: unparser
: <filebw> ( path -- stream )
<filecw> ;
: <server> ( port -- stream )
#! Starts listening on localhost:port. Returns a stream that
#! you can close with fclose, and accept connections from
#! with accept. No other stream operations are supported.
server-socket <stream> [
"socket" set
( -- )
[ "socket" get close-fd ] "fclose" set
] extend ;
: <client-stream> ( host port in out -- stream )
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
: <client> ( host port -- stream )
#! fflush yields until connection is established.
2dup client-socket <client-stream> dup fflush ;
: accept ( server -- client )
#! Accept a connection from a server socket.
"socket" swap get* blocking-accept <client-stream> ;
: init-stdio ( -- )
stdin stdout <fd-stream> <stdio-stream> "stdio" set ;

44
library/vocabularies.factor
View File

@ -63,3 +63,47 @@ USE: strings
: intern ( "word" -- word )
#! Returns the top of the stack if it already been interned.
dup string? [ "use" get search ] when ;
: init-search-path ( -- )
! For files
"user" "file-in" set
[ "user" "builtins" ] "file-use" set
! For interactive
"user" "in" set
[
"user"
"arithmetic"
"builtins"
"combinators"
"compiler"
"continuations"
"errors"
"debugger"
"hashtables"
"inspector"
"interpreter"
"jedit"
"kernel"
"lists"
"logic"
"math"
"namespaces"
"parser"
"prettyprint"
"stack"
"streams"
"stdio"
"strings"
"test"
"trace"
"unparser"
"vectors"
"vocabularies"
"words"
"scratchpad"
] "use" set ;
: init-scratchpad ( -- )
#! The contents of the scratchpad vocabulary is not saved
#! between runs.
<namespace> "scratchpad" "vocabularies" get set* ;

14
native/error.c
View File

@ -15,11 +15,11 @@ void critical_error(char* msg, CELL tagged)
void fix_stacks(void)
{
if(STACK_UNDERFLOW(env.ds,env.ds_bot)
|| STACK_OVERFLOW(env.ds,env.ds_bot))
if(STACK_UNDERFLOW(ds,ds_bot)
|| STACK_OVERFLOW(ds,ds_bot))
reset_datastack();
if(STACK_UNDERFLOW(env.cs,env.cs_bot)
|| STACK_OVERFLOW(env.cs,env.cs_bot))
if(STACK_UNDERFLOW(cs,cs_bot)
|| STACK_OVERFLOW(cs,cs_bot))
reset_callstack();
}
@ -29,9 +29,9 @@ void throw_error(CELL error)
dpush(error);
/* Execute the 'throw' word */
cpush(env.cf);
env.cf = env.user[BREAK_ENV];
if(env.cf == 0)
cpush(callframe);
callframe = userenv[BREAK_ENV];
if(callframe == 0)
{
/* Crash at startup */
fatal_error("Error thrown before BREAK_ENV set",error);

9
native/gc.c
View File

@ -123,17 +123,16 @@ void collect_roots(void)
gc_debug("f",F);
copy_object(&T);
gc_debug("t",T);
copy_object(&env.cf);
copy_object(&env.boot);
copy_object(&callframe);
for(ptr = env.ds_bot; ptr < env.ds; ptr += CELLS)
for(ptr = ds_bot; ptr < ds; ptr += CELLS)
copy_object((void*)ptr);
for(ptr = env.cs_bot; ptr < env.cs; ptr += CELLS)
for(ptr = cs_bot; ptr < cs; ptr += CELLS)
copy_object((void*)ptr);
for(i = 0; i < USER_ENV; i++)
copy_object(&env.user[i]);
copy_object(&userenv[i]);
}
void primitive_gc(void)

24
native/image.c
View File

@ -6,10 +6,11 @@ void load_image(char* filename)
HEADER h;
CELL size;
printf("Loading %s...",filename);
fflush(stdout);
fprintf(stderr,"Loading %s...",filename);
file = fopen(filename,"rb");
if(file < 0)
fatal_error("Cannot open image for reading",errno);
/* read it in native byte order */
fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
@ -29,18 +30,17 @@ void load_image(char* filename)
active->here = active->base + h.size;
fclose(file);
printf(" relocating...");
fprintf(stderr," relocating...");
fflush(stdout);
clear_environment();
env.boot = h.boot;
env.user[GLOBAL_ENV] = h.global;
userenv[GLOBAL_ENV] = h.global;
userenv[BOOT_ENV] = h.boot;
relocate(h.relocation_base);
printf(" done\n");
fprintf(stderr," done\n");
}
bool save_image(char* filename)
@ -48,16 +48,18 @@ bool save_image(char* filename)
FILE* file;
HEADER h;
printf("Saving %s\n",filename);
fprintf(stderr,"Saving %s...\n",filename);
file = fopen(filename,"wb");
if(file < 0)
fatal_error("Cannot open image for writing",errno);
h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION;
h.relocation_base = active->base;
h.boot = env.boot;
h.boot = userenv[BOOT_ENV];
h.size = (active->here - active->base);
h.global = env.user[GLOBAL_ENV];
h.global = userenv[GLOBAL_ENV];
fwrite(&h,sizeof(HEADER),1,file);
fwrite((void*)active->base,h.size,1,file);

4
native/io.c
View File

@ -14,8 +14,8 @@ void init_io_tasks(fd_set* fdset, IO_TASK* io_tasks)
void init_io(void)
{
env.user[STDIN_ENV] = tag_object(port(PORT_READ,0));
env.user[STDOUT_ENV] = tag_object(port(PORT_WRITE,1));
userenv[STDIN_ENV] = tag_object(port(PORT_READ,0));
userenv[STDOUT_ENV] = tag_object(port(PORT_WRITE,1));
read_fd_count = 0;
init_io_tasks(&read_fd_set,read_io_tasks);

4
native/memory.c
View File

@ -54,8 +54,8 @@ void check_memory(void)
}
/* Execute the 'garbage-collection' word */
cpush(env.cf);
env.cf = env.user[GC_ENV];
cpush(callframe);
callframe = userenv[GC_ENV];
}
}

4
native/relocate.c
View File

@ -48,8 +48,8 @@ void relocate(CELL r)
{
relocation_base = r;
fixup(&env.boot);
fixup(&env.user[GLOBAL_ENV]);
fixup(&userenv[BOOT_ENV]);
fixup(&userenv[GLOBAL_ENV]);
relocating = active->base;

44
native/run.c
View File

@ -21,7 +21,7 @@ void clear_environment(void)
{
int i;
for(i = 0; i < USER_ENV; i++)
env.user[i] = 0;
userenv[i] = 0;
}
#define EXECUTE(w) ((XT)(w->xt))()
@ -35,20 +35,20 @@ void run(void)
for(;;)
{
if(env.cf == F)
if(callframe == F)
{
env.cf = cpop();
callframe = cpop();
continue;
}
env.cf = (CELL)untag_cons(env.cf);
next = get(env.cf);
env.cf = get(env.cf + CELLS);
callframe = (CELL)untag_cons(callframe);
next = get(callframe);
callframe = get(callframe + CELLS);
if(TAG(next) == WORD_TYPE)
{
env.w = (WORD*)UNTAG(next);
EXECUTE(env.w);
executing = (WORD*)UNTAG(next);
EXECUTE(executing);
}
else
dpush(next);
@ -58,33 +58,33 @@ void run(void)
/* XT of deferred words */
void undefined()
{
general_error(ERROR_UNDEFINED_WORD,tag_word(env.w));
general_error(ERROR_UNDEFINED_WORD,tag_word(executing));
}
/* XT of compound definitions */
void call()
{
/* tail call optimization */
if(env.cf != F)
cpush(env.cf);
if(callframe != F)
cpush(callframe);
/* the parameter is the colon def */
env.cf = env.w->parameter;
callframe = executing->parameter;
}
void primitive_execute(void)
{
WORD* word = untag_word(dpop());
env.w = word;
EXECUTE(env.w);
executing = word;
EXECUTE(executing);
}
void primitive_call(void)
{
CELL calling = dpop();
if(env.cf != F)
cpush(env.cf);
env.cf = calling;
if(callframe != F)
cpush(callframe);
callframe = calling;
}
void primitive_ifte(void)
@ -93,9 +93,9 @@ void primitive_ifte(void)
CELL t = dpop();
CELL cond = dpop();
CELL calling = (untag_boolean(cond) ? t : f);
if(env.cf != F)
cpush(env.cf);
env.cf = calling;
if(callframe != F)
cpush(callframe);
callframe = calling;
}
void primitive_getenv(void)
@ -103,7 +103,7 @@ void primitive_getenv(void)
FIXNUM e = to_fixnum(dpeek());
if(e < 0 || e >= USER_ENV)
range_error(F,e,USER_ENV);
drepl(env.user[e]);
drepl(userenv[e]);
}
void primitive_setenv(void)
@ -112,5 +112,5 @@ void primitive_setenv(void)
CELL value = dpop();
if(e < 0 || e >= USER_ENV)
range_error(F,e,USER_ENV);
env.user[e] = value;
userenv[e] = value;
}

61
native/run.h
View File

@ -8,30 +8,31 @@
#define BREAK_ENV 5
#define CATCHSTACK_ENV 6
#define GC_ENV 7
#define BOOT_ENV 8
/* Error handlers restore this */
sigjmp_buf toplevel;
typedef struct {
/* TAGGED currently executing quotation */
CELL cf;
/* raw pointer to datastack bottom */
CELL ds_bot;
/* raw pointer to datastack top */
CELL ds;
/* raw pointer to callstack bottom */
CELL cs_bot;
/* raw pointer to callstack top */
CELL cs;
/* raw pointer to currently executing word */
WORD* w;
/* TAGGED bootstrap quotation */
CELL boot;
/* TAGGED user environment data */
CELL user[USER_ENV];
} ENV;
/* TAGGED currently executing quotation */
CELL callframe;
ENV env;
/* raw pointer to datastack bottom */
CELL ds_bot;
/* raw pointer to datastack top */
CELL ds;
/* raw pointer to callstack bottom */
CELL cs_bot;
/* raw pointer to callstack top */
CELL cs;
/* raw pointer to currently executing word */
WORD* executing;
/* TAGGED user environment data; see getenv/setenv prims */
CELL userenv[USER_ENV];
void init_signals(void);
@ -39,41 +40,41 @@ void clear_environment(void);
INLINE CELL dpop(void)
{
env.ds -= CELLS;
return get(env.ds);
ds -= CELLS;
return get(ds);
}
INLINE void drepl(CELL top)
{
put(env.ds - CELLS,top);
put(ds - CELLS,top);
}
INLINE void dpush(CELL top)
{
put(env.ds,top);
env.ds += CELLS;
put(ds,top);
ds += CELLS;
}
INLINE CELL dpeek(void)
{
return get(env.ds - CELLS);
return get(ds - CELLS);
}
INLINE CELL cpop(void)
{
env.cs -= CELLS;
return get(env.cs);
cs -= CELLS;
return get(cs);
}
INLINE void cpush(CELL top)
{
put(env.cs,top);
env.cs += CELLS;
put(cs,top);
cs += CELLS;
}
INLINE CELL cpeek(void)
{
return get(env.cs - CELLS);
return get(cs - CELLS);
}
void run(void);

46
native/stack.c
View File

@ -2,21 +2,21 @@
void reset_datastack(void)
{
env.ds = env.ds_bot;
ds = ds_bot;
}
void reset_callstack(void)
{
env.cs = env.cs_bot;
cs = cs_bot;
}
void init_stacks(void)
{
env.ds_bot = (CELL)alloc_guarded(STACK_SIZE);
ds_bot = (CELL)alloc_guarded(STACK_SIZE);
reset_datastack();
env.cs_bot = (CELL)alloc_guarded(STACK_SIZE);
cs_bot = (CELL)alloc_guarded(STACK_SIZE);
reset_callstack();
env.cf = env.boot;
callframe = userenv[BOOT_ENV];
}
void primitive_drop(void)
@ -32,44 +32,44 @@ void primitive_dup(void)
void primitive_swap(void)
{
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
put(env.ds - CELLS,next);
put(env.ds - CELLS * 2,top);
CELL next = get(ds - CELLS * 2);
put(ds - CELLS,next);
put(ds - CELLS * 2,top);
}
void primitive_over(void)
{
dpush(get(env.ds - CELLS * 2));
dpush(get(ds - CELLS * 2));
}
void primitive_pick(void)
{
dpush(get(env.ds - CELLS * 3));
dpush(get(ds - CELLS * 3));
}
void primitive_nip(void)
{
CELL top = dpop();
put(env.ds - CELLS,top);
put(ds - CELLS,top);
}
void primitive_tuck(void)
{
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
put(env.ds - CELLS * 2,top);
put(env.ds - CELLS,next);
CELL next = get(ds - CELLS * 2);
put(ds - CELLS * 2,top);
put(ds - CELLS,next);
dpush(top);
}
void primitive_rot(void)
{
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
CELL next_next = get(env.ds - CELLS * 3);
put(env.ds - CELLS * 3,next);
put(env.ds - CELLS * 2,top);
put(env.ds - CELLS,next_next);
CELL next = get(ds - CELLS * 2);
CELL next_next = get(ds - CELLS * 3);
put(ds - CELLS * 3,next);
put(ds - CELLS * 2,top);
put(ds - CELLS,next_next);
}
void primitive_to_r(void)
@ -94,12 +94,12 @@ VECTOR* stack_to_vector(CELL bottom, CELL top)
void primitive_datastack(void)
{
dpush(tag_object(stack_to_vector(env.ds_bot,env.ds)));
dpush(tag_object(stack_to_vector(ds_bot,ds)));
}
void primitive_callstack(void)
{
dpush(tag_object(stack_to_vector(env.cs_bot,env.cs)));
dpush(tag_object(stack_to_vector(cs_bot,cs)));
}
/* Returns top of stack */
@ -113,10 +113,10 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom)
void primitive_set_datastack(void)
{
env.ds = vector_to_stack(untag_vector(dpop()),env.ds_bot);
ds = vector_to_stack(untag_vector(dpop()),ds_bot);
}
void primitive_set_callstack(void)
{
env.cs = vector_to_stack(untag_vector(dpop()),env.cs_bot);
cs = vector_to_stack(untag_vector(dpop()),cs_bot);
}