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

47
contrib/irc.factor
View File

@ -68,18 +68,21 @@ USE: unparser
: keep-datastack ( quot -- ) : keep-datastack ( quot -- )
datastack [ call ] dip set-datastack drop ; 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 ) : <irc-stream> ( stream recepient -- stream )
<stream> [ <stream> [
"recepient" set "recepient" set
"stdio" set "stdio" set
100 <sbuf> "buf" set 100 <sbuf> "buf" set
[ [
dup "buf" get sbuf-append irc-stream-write
ends-with-newline? [
"buf" get >str
0 "buf" get set-sbuf-length
"\n" split [ "recepient" get irc-message ] each
] when
] "fwrite" set ] "fwrite" set
] extend ; ] extend ;
@ -100,15 +103,17 @@ USE: unparser
: irc-action-quot ( action -- quot ) : irc-action-quot ( action -- quot )
[ [
[ "eval" irc-eval ] [ "eval" swap [ irc-eval ] with-irc-stream ]
[ "see" see terpri ] [ "see" swap [ see terpri ] with-irc-stream ]
] assoc [ [ drop ] ] unless* ; [ "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 ; " " split1 swap irc-action-quot call ;
: irc-handle-privmsg ( [ recepient message ] -- ) : irc-handle-privmsg ( [ recepient message ] -- )
uncons car swap [ irc-action-handler ] with-irc-stream ; uncons car irc-action-handler ;
: irc-handle-join ( [ joined channel ] -- ) : irc-handle-join ( [ joined channel ] -- )
uncons car uncons car
@ -130,13 +135,21 @@ USE: unparser
global [ print ] bind ; global [ print ] bind ;
: irc-quit-flag ( -- ? )
global [ "irc-quit-flag" get ] bind ;
: clear-irc-quit-flag ( -- ? )
global [ "irc-quit-flag" off ] bind ;
: irc-loop ( -- ) : 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 ( channels -- )
irc-register irc-register
dup [ irc-join ] each ! "identify foobar" "NickServ" irc-message
[ "Hello everybody" swap irc-message ] each [ irc-join ] each
irc-loop ; irc-loop ;
: irc-test : irc-test
@ -145,8 +158,8 @@ USE: unparser
"irc.freenode.net" "server" set "irc.freenode.net" "server" set
"Factor" "realname" set "Factor" "realname" set
"factorbot" "nick" set "factorbot" "nick" set
<namespace> "facts" set "irc.freenode.net" 6667 <client> [
"irc.freenode.net" 6667 <client> [ "#factor" ] irc
<namespace> [ "stdio" set [ "#factor" ] irc ] bind ; ] with-stream ;
!! "factor/irc.factor" run-file !! "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 prop = "factor.completion.plain";
String stackEffect = null; String stackEffect = null;
if(!value instanceof FactorWord) if(!(value instanceof FactorWord))
return this; return this;
FactorWord word = (FactorWord)value; 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 ; swap write-image ;
: make-images ( -- ) : make-images ( -- )
"big-endian" off "factor.image.le" make-image "big-endian" off "boot.image.le" make-image
"big-endian" on "factor.image.be" 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 nip
] [ ] [
drop drop
"Forward reference: " write dup .
! Remember where we are, and add the reference later ! Remember where we are, and add the reference later
dup fixup-word-later dup fixup-word-later
] ifte ; ] ifte ;

44
library/init.factor
View File

@ -87,50 +87,6 @@ USE: words
#! Parse command line arguments. #! Parse command line arguments.
parse-switches run-files ; 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 ( -- ) : init-toplevel ( -- )
[ "top-level-continuation" set ] callcc0 ; [ "top-level-continuation" set ] callcc0 ;

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

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

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

@ -34,7 +34,7 @@ USE: lists
USE: stack USE: stack
: <regex> ( pattern -- regex ) : <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 [ dup "java.util.regex.Pattern" is not [
[ "java.lang.String" ] [ "java.lang.String" ]
"java.util.regex.Pattern" "compile" "java.util.regex.Pattern" "compile"
@ -54,10 +54,10 @@ USE: stack
<regex> <matcher> re-matches* ; <regex> <matcher> re-matches* ;
: [re-matches] ( matcher code -- boolean ) : [re-matches] ( matcher code -- boolean )
! If the matcher's re-matches* function returns true, #! If the matcher's re-matches* function returns true,
! evaluate the code with the matcher at the top of the #! evaluate the code with the matcher at the top of the
! stack. Otherwise, pop the matcher off the stack and #! stack. Otherwise, pop the matcher off the stack and
! push f. #! push f.
[ dup re-matches* ] dip [ drop f ] ifte ; [ dup re-matches* ] dip [ drop f ] ifte ;
: re-replace* ( replace matcher -- string ) : re-replace* ( replace matcher -- string )
@ -65,8 +65,8 @@ USE: stack
"replaceAll" jinvoke ; "replaceAll" jinvoke ;
: re-replace ( input regex replace -- string ) : re-replace ( input regex replace -- string )
! Replaces all occurrences of the regex in the input string #! Replaces all occurrences of the regex in the input string
! with the replace string. #! with the replace string.
-rot <regex> <matcher> re-replace* ; -rot <regex> <matcher> re-replace* ;
: re-split ( string split -- list ) : re-split ( string split -- list )
@ -95,23 +95,3 @@ USE: stack
: group1 ( string regex -- string ) : group1 ( string regex -- string )
groups dup [ car ] when ; 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 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USE: arithmetic
USE: combinators
USE: format
USE: inspector
USE: init
USE: kernel
USE: lists USE: lists
USE: logic
USE: math
USE: namespaces
USE: stack
USE: stdio
USE: streams
USE: strings
USE: vectors
USE: words
USE: cross-compiler USE: cross-compiler
primitives, primitives,
[ [
"/library/ansi.factor" "/library/platform/native/kernel.factor"
"/library/assoc.factor" "/library/platform/native/stack.factor"
"/library/cross-compiler.factor"
"/library/combinators.factor"
"/library/cons.factor" "/library/cons.factor"
"/library/continuations.factor" "/library/combinators.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/logic.factor" "/library/logic.factor"
"/library/namespaces.factor" "/library/platform/native/vectors.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/vector-combinators.factor" "/library/vector-combinators.factor"
"/library/vocabularies.factor" "/library/lists.factor"
"/library/vocabulary-style.factor" "/library/assoc.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/math/arithmetic.factor" "/library/math/arithmetic.factor"
"/library/math/list-math.factor"
"/library/math/math.factor"
"/library/math/math-combinators.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/namespace-math.factor"
"/library/math/pow.factor" "/library/list-namespaces.factor"
"/library/math/quadratic.factor" "/library/sbuf.factor"
"/library/math/trig-hyp.factor" "/library/continuations.factor"
"/library/math/simpson.factor"
"/library/test/test.factor"
"/library/platform/native/errors.factor" "/library/platform/native/errors.factor"
"/library/errors.factor"
"/library/stream.factor"
"/library/platform/native/io-internals.factor" "/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor" "/library/platform/native/stream.factor"
"/library/platform/native/namespaces.factor" "/library/stdio.factor"
"/library/platform/native/strings.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/parse-numbers.factor"
"/library/platform/native/parser.factor" "/library/platform/native/parser.factor"
"/library/platform/native/parse-syntax.factor" "/library/platform/native/parse-syntax.factor"
"/library/platform/native/parse-stream.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/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" "/library/platform/native/init.factor"
] [ ] [
cross-compile-resource cross-compile-resource
@ -127,4 +79,7 @@ primitives,
version, 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 -- ) : cross-compile-resource ( resource -- )
[ [
! Change behavior of ; ! Change behavior of ;
"cross-compiling" on [ compound, ] ";-hook" set
run-resource run-resource
] with-scope ; ] 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. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: errors IN: errors
USE: arithmetic
USE: combinators
USE: continuations
USE: kernel USE: kernel
USE: lists
USE: logic
USE: namespaces
USE: prettyprint
USE: stack
USE: stdio
USE: strings
USE: unparser
USE: vectors USE: vectors
! This is a very lightweight exception handling system. ! This is a very lightweight exception handling system.
@ -47,43 +36,8 @@ USE: vectors
: set-catchstack* ( cs -- ) 6 setenv ; : set-catchstack* ( cs -- ) 6 setenv ;
: set-catchstack ( cs -- ) clone set-catchstack* ; : 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: >c
DEFER: throw DEFER: throw
DEFER: default-error-handler
: init-errors ( -- ) : init-errors ( -- )
64 <vector> set-catchstack* 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 ;

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

@ -26,58 +26,32 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init IN: init
USE: ansi
USE: arithmetic
USE: errors
USE: combinators USE: combinators
USE: hashtables USE: errors
USE: httpd-responder
USE: kernel USE: kernel
USE: lists
USE: logic
USE: interpreter
USE: io-internals
USE: math
USE: random
USE: namespaces USE: namespaces
USE: parser USE: parser
USE: prettyprint
USE: stack
USE: stdio USE: stdio
USE: streams USE: streams
USE: strings
USE: styles
USE: vectors
USE: words USE: words
USE: unparser
: init-gc ( -- ) : init-gc ( -- )
[ garbage-collection ] 7 setenv ; [ garbage-collection ] 7 setenv ;
: boot ( -- ) : boot ( -- )
#! Initialize an interpreter with the basic services.
init-gc init-gc
init-random
init-namespaces init-namespaces
init-stdio 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-errors
init-search-path "HOME" os-env [ "." ] unless* "~" set
init-scratchpad 10 "base" set
init-styles "/" "/" set
init-vocab-styles init-search-path ;
default-responders
run-user-init : cold-boot ( -- )
#! An initially-generated image has this as the boot
"interactive" get [ init-interpreter ] when #! quotation.
boot
0 exit* ; "/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 IN: namespaces
DEFER: init-namespaces DEFER: init-namespaces
IN: vectors
DEFER: vector=
IN: errors
DEFER: init-errors
IN: kernel IN: kernel
USE: arithmetic USE: arithmetic
USE: combinators USE: combinators
@ -42,6 +48,7 @@ USE: strings
USE: vectors USE: vectors
USE: words USE: words
USE: unparser USE: unparser
USE: vectors
: hashcode ( obj -- hash ) : hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes. #! 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. #! Begin a word definition. Word name follows.
CREATE dup remember-where [ ] ; parsing CREATE dup remember-where [ ] ; parsing
: ;-hook ( -- quot )
";-hook" get [ [ define-compound ] ] unless* ;
: ; : ;
#! End a word definition. #! End a word definition.
nreverse nreverse
"cross-compiling" get ;-hook call ; parsing
[ compound, ] [ define-compound ] ifte ; parsing
! Vocabularies ! Vocabularies
: DEFER: CREATE drop ; parsing : DEFER: CREATE drop ; parsing
@ -116,14 +118,16 @@ USE: unparser
ascii-escape>ch ascii-escape>ch
] ifte ; ] ifte ;
! String literal
: parse-escape ( -- ) : parse-escape ( -- )
next-ch escape dup [ drop "Bad escape" throw ] unless ; next-ch escape dup [ drop "Bad escape" throw ] unless ;
: parse-ch ( ch -- ch ) : parse-ch ( ch -- ch )
dup CHAR: \\ = [ drop parse-escape ] when ; dup CHAR: \\ = [ drop parse-escape ] when ;
! Char literal
: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
! String literal
: parse-string ( -- ) : parse-string ( -- )
next-ch dup CHAR: " = [ next-ch dup CHAR: " = [
drop drop
@ -136,9 +140,6 @@ USE: unparser
#! the <% %> scope up to the original scope. #! the <% %> scope up to the original scope.
<% parse-string "col" get %> swap "col" set parsed ; parsing <% parse-string "col" get %> swap "col" set parsed ; parsing
! Char literal
: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
! Complex literal ! Complex literal
: #{ : #{
#! Read #{ real imaginary #} #! Read #{ real imaginary #}

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

@ -56,9 +56,10 @@ USE: unparser
] ifte ; ] ifte ;
: parsing ( -- ) : parsing ( -- )
"cross-compiling" get [ #! Mark the most recently defined word to execute at parse
t "parsing" word set-word-property #! time, rather than run time. The word can use 'scan' to
] unless ; parsing #! read ahead in the input stream.
t "parsing" word set-word-property ;
: <parsing "line" set 0 "col" set ; : <parsing "line" set 0 "col" set ;
: parsing> "line" off "col" off ; : parsing> "line" off "col" off ;
@ -171,3 +172,8 @@ USE: unparser
: next-word-ch ( -- ch ) : next-word-ch ( -- ch )
"col" get "line" get skip-blank "col" set next-ch ; "col" get "line" get skip-blank "col" set next-ch ;
! 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: stdio
USE: strings USE: strings
USE: namespaces USE: namespaces
USE: unparser
: <fd-stream> ( in out -- stream ) : <fd-stream> ( in out -- stream )
#! Create a file descriptor stream object, wrapping a pair #! Create a file descriptor stream object, wrapping a pair
@ -78,28 +77,6 @@ USE: unparser
: <filebw> ( path -- stream ) : <filebw> ( path -- stream )
<filecw> ; <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 ( -- ) : init-stdio ( -- )
stdin stdout <fd-stream> <stdio-stream> "stdio" set ; stdin stdout <fd-stream> <stdio-stream> "stdio" set ;

44
library/vocabularies.factor
View File

@ -63,3 +63,47 @@ USE: strings
: intern ( "word" -- word ) : intern ( "word" -- word )
#! Returns the top of the stack if it already been interned. #! Returns the top of the stack if it already been interned.
dup string? [ "use" get search ] when ; 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) void fix_stacks(void)
{ {
if(STACK_UNDERFLOW(env.ds,env.ds_bot) if(STACK_UNDERFLOW(ds,ds_bot)
|| STACK_OVERFLOW(env.ds,env.ds_bot)) || STACK_OVERFLOW(ds,ds_bot))
reset_datastack(); reset_datastack();
if(STACK_UNDERFLOW(env.cs,env.cs_bot) if(STACK_UNDERFLOW(cs,cs_bot)
|| STACK_OVERFLOW(env.cs,env.cs_bot)) || STACK_OVERFLOW(cs,cs_bot))
reset_callstack(); reset_callstack();
} }
@ -29,9 +29,9 @@ void throw_error(CELL error)
dpush(error); dpush(error);
/* Execute the 'throw' word */ /* Execute the 'throw' word */
cpush(env.cf); cpush(callframe);
env.cf = env.user[BREAK_ENV]; callframe = userenv[BREAK_ENV];
if(env.cf == 0) if(callframe == 0)
{ {
/* Crash at startup */ /* Crash at startup */
fatal_error("Error thrown before BREAK_ENV set",error); 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); gc_debug("f",F);
copy_object(&T); copy_object(&T);
gc_debug("t",T); gc_debug("t",T);
copy_object(&env.cf); copy_object(&callframe);
copy_object(&env.boot);
for(ptr = env.ds_bot; ptr < env.ds; ptr += CELLS) for(ptr = ds_bot; ptr < ds; ptr += CELLS)
copy_object((void*)ptr); 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); copy_object((void*)ptr);
for(i = 0; i < USER_ENV; i++) for(i = 0; i < USER_ENV; i++)
copy_object(&env.user[i]); copy_object(&userenv[i]);
} }
void primitive_gc(void) void primitive_gc(void)

22
native/image.c
View File

@ -6,10 +6,11 @@ void load_image(char* filename)
HEADER h; HEADER h;
CELL size; CELL size;
printf("Loading %s...",filename); fprintf(stderr,"Loading %s...",filename);
fflush(stdout);
file = fopen(filename,"rb"); file = fopen(filename,"rb");
if(file < 0)
fatal_error("Cannot open image for reading",errno);
/* read it in native byte order */ /* read it in native byte order */
fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file); fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
@ -29,18 +30,17 @@ void load_image(char* filename)
active->here = active->base + h.size; active->here = active->base + h.size;
fclose(file); fclose(file);
printf(" relocating..."); fprintf(stderr," relocating...");
fflush(stdout); fflush(stdout);
clear_environment(); clear_environment();
env.boot = h.boot; userenv[GLOBAL_ENV] = h.global;
userenv[BOOT_ENV] = h.boot;
env.user[GLOBAL_ENV] = h.global;
relocate(h.relocation_base); relocate(h.relocation_base);
printf(" done\n"); fprintf(stderr," done\n");
} }
bool save_image(char* filename) bool save_image(char* filename)
@ -48,16 +48,18 @@ bool save_image(char* filename)
FILE* file; FILE* file;
HEADER h; HEADER h;
printf("Saving %s\n",filename); fprintf(stderr,"Saving %s...\n",filename);
file = fopen(filename,"wb"); file = fopen(filename,"wb");
if(file < 0)
fatal_error("Cannot open image for writing",errno);
h.magic = IMAGE_MAGIC; h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION; h.version = IMAGE_VERSION;
h.relocation_base = active->base; h.relocation_base = active->base;
h.boot = env.boot; h.boot = userenv[BOOT_ENV];
h.size = (active->here - active->base); h.size = (active->here - active->base);
h.global = env.user[GLOBAL_ENV]; h.global = userenv[GLOBAL_ENV];
fwrite(&h,sizeof(HEADER),1,file); fwrite(&h,sizeof(HEADER),1,file);
fwrite((void*)active->base,h.size,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) void init_io(void)
{ {
env.user[STDIN_ENV] = tag_object(port(PORT_READ,0)); userenv[STDIN_ENV] = tag_object(port(PORT_READ,0));
env.user[STDOUT_ENV] = tag_object(port(PORT_WRITE,1)); userenv[STDOUT_ENV] = tag_object(port(PORT_WRITE,1));
read_fd_count = 0; read_fd_count = 0;
init_io_tasks(&read_fd_set,read_io_tasks); 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 */ /* Execute the 'garbage-collection' word */
cpush(env.cf); cpush(callframe);
env.cf = env.user[GC_ENV]; callframe = userenv[GC_ENV];
} }
} }

4
native/relocate.c
View File

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

44
native/run.c
View File

@ -21,7 +21,7 @@ void clear_environment(void)
{ {
int i; int i;
for(i = 0; i < USER_ENV; i++) for(i = 0; i < USER_ENV; i++)
env.user[i] = 0; userenv[i] = 0;
} }
#define EXECUTE(w) ((XT)(w->xt))() #define EXECUTE(w) ((XT)(w->xt))()
@ -35,20 +35,20 @@ void run(void)
for(;;) for(;;)
{ {
if(env.cf == F) if(callframe == F)
{ {
env.cf = cpop(); callframe = cpop();
continue; continue;
} }
env.cf = (CELL)untag_cons(env.cf); callframe = (CELL)untag_cons(callframe);
next = get(env.cf); next = get(callframe);
env.cf = get(env.cf + CELLS); callframe = get(callframe + CELLS);
if(TAG(next) == WORD_TYPE) if(TAG(next) == WORD_TYPE)
{ {
env.w = (WORD*)UNTAG(next); executing = (WORD*)UNTAG(next);
EXECUTE(env.w); EXECUTE(executing);
} }
else else
dpush(next); dpush(next);
@ -58,33 +58,33 @@ void run(void)
/* XT of deferred words */ /* XT of deferred words */
void undefined() void undefined()
{ {
general_error(ERROR_UNDEFINED_WORD,tag_word(env.w)); general_error(ERROR_UNDEFINED_WORD,tag_word(executing));
} }
/* XT of compound definitions */ /* XT of compound definitions */
void call() void call()
{ {
/* tail call optimization */ /* tail call optimization */
if(env.cf != F) if(callframe != F)
cpush(env.cf); cpush(callframe);
/* the parameter is the colon def */ /* the parameter is the colon def */
env.cf = env.w->parameter; callframe = executing->parameter;
} }
void primitive_execute(void) void primitive_execute(void)
{ {
WORD* word = untag_word(dpop()); WORD* word = untag_word(dpop());
env.w = word; executing = word;
EXECUTE(env.w); EXECUTE(executing);
} }
void primitive_call(void) void primitive_call(void)
{ {
CELL calling = dpop(); CELL calling = dpop();
if(env.cf != F) if(callframe != F)
cpush(env.cf); cpush(callframe);
env.cf = calling; callframe = calling;
} }
void primitive_ifte(void) void primitive_ifte(void)
@ -93,9 +93,9 @@ void primitive_ifte(void)
CELL t = dpop(); CELL t = dpop();
CELL cond = dpop(); CELL cond = dpop();
CELL calling = (untag_boolean(cond) ? t : f); CELL calling = (untag_boolean(cond) ? t : f);
if(env.cf != F) if(callframe != F)
cpush(env.cf); cpush(callframe);
env.cf = calling; callframe = calling;
} }
void primitive_getenv(void) void primitive_getenv(void)
@ -103,7 +103,7 @@ void primitive_getenv(void)
FIXNUM e = to_fixnum(dpeek()); FIXNUM e = to_fixnum(dpeek());
if(e < 0 || e >= USER_ENV) if(e < 0 || e >= USER_ENV)
range_error(F,e,USER_ENV); range_error(F,e,USER_ENV);
drepl(env.user[e]); drepl(userenv[e]);
} }
void primitive_setenv(void) void primitive_setenv(void)
@ -112,5 +112,5 @@ void primitive_setenv(void)
CELL value = dpop(); CELL value = dpop();
if(e < 0 || e >= USER_ENV) if(e < 0 || e >= USER_ENV)
range_error(F,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 BREAK_ENV 5
#define CATCHSTACK_ENV 6 #define CATCHSTACK_ENV 6
#define GC_ENV 7 #define GC_ENV 7
#define BOOT_ENV 8
/* Error handlers restore this */ /* Error handlers restore this */
sigjmp_buf toplevel; sigjmp_buf toplevel;
typedef struct { /* TAGGED currently executing quotation */
/* TAGGED currently executing quotation */ CELL callframe;
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;
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); void init_signals(void);
@ -39,41 +40,41 @@ void clear_environment(void);
INLINE CELL dpop(void) INLINE CELL dpop(void)
{ {
env.ds -= CELLS; ds -= CELLS;
return get(env.ds); return get(ds);
} }
INLINE void drepl(CELL top) INLINE void drepl(CELL top)
{ {
put(env.ds - CELLS,top); put(ds - CELLS,top);
} }
INLINE void dpush(CELL top) INLINE void dpush(CELL top)
{ {
put(env.ds,top); put(ds,top);
env.ds += CELLS; ds += CELLS;
} }
INLINE CELL dpeek(void) INLINE CELL dpeek(void)
{ {
return get(env.ds - CELLS); return get(ds - CELLS);
} }
INLINE CELL cpop(void) INLINE CELL cpop(void)
{ {
env.cs -= CELLS; cs -= CELLS;
return get(env.cs); return get(cs);
} }
INLINE void cpush(CELL top) INLINE void cpush(CELL top)
{ {
put(env.cs,top); put(cs,top);
env.cs += CELLS; cs += CELLS;
} }
INLINE CELL cpeek(void) INLINE CELL cpeek(void)
{ {
return get(env.cs - CELLS); return get(cs - CELLS);
} }
void run(void); void run(void);

46
native/stack.c
View File

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