dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
- \ eval-callback ?callback 16 setenv
- \ yield-callback ?callback 17 setenv
- \ sleep-callback ?callback 18 setenv ;
+ \ eval-callback ?callback 16 set-special-object
+ \ yield-callback ?callback 17 set-special-object
+ \ sleep-callback ?callback 18 set-special-object ;
MAIN: init-remote-control
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.binary io.files io.encodings.binary
CONSTANT: data-base 1024
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 70
CONSTANT: header-size 10
RESET
! Boot quotation, set in stage1.factor
-USERENV: bootstrap-startup-quot 20
+SPECIAL-OBJECT: bootstrap-startup-quot 20
! Bootstrap global namesapce
-USERENV: bootstrap-global 21
+SPECIAL-OBJECT: bootstrap-global 21
! JIT parameters
-USERENV: jit-prolog 23
-USERENV: jit-primitive-word 24
-USERENV: jit-primitive 25
-USERENV: jit-word-jump 26
-USERENV: jit-word-call 27
-USERENV: jit-if-word 28
-USERENV: jit-if 29
-USERENV: jit-epilog 30
-USERENV: jit-return 31
-USERENV: jit-profiling 32
-USERENV: jit-push 33
-USERENV: jit-dip-word 34
-USERENV: jit-dip 35
-USERENV: jit-2dip-word 36
-USERENV: jit-2dip 37
-USERENV: jit-3dip-word 38
-USERENV: jit-3dip 39
-USERENV: jit-execute 40
-USERENV: jit-declare-word 41
-
-USERENV: c-to-factor-word 42
-USERENV: lazy-jit-compile-word 43
-USERENV: unwind-native-frames-word 44
-
-USERENV: callback-stub 48
+SPECIAL-OBJECT: jit-prolog 23
+SPECIAL-OBJECT: jit-primitive-word 24
+SPECIAL-OBJECT: jit-primitive 25
+SPECIAL-OBJECT: jit-word-jump 26
+SPECIAL-OBJECT: jit-word-call 27
+SPECIAL-OBJECT: jit-if-word 28
+SPECIAL-OBJECT: jit-if 29
+SPECIAL-OBJECT: jit-epilog 30
+SPECIAL-OBJECT: jit-return 31
+SPECIAL-OBJECT: jit-profiling 32
+SPECIAL-OBJECT: jit-push 33
+SPECIAL-OBJECT: jit-dip-word 34
+SPECIAL-OBJECT: jit-dip 35
+SPECIAL-OBJECT: jit-2dip-word 36
+SPECIAL-OBJECT: jit-2dip 37
+SPECIAL-OBJECT: jit-3dip-word 38
+SPECIAL-OBJECT: jit-3dip 39
+SPECIAL-OBJECT: jit-execute 40
+SPECIAL-OBJECT: jit-declare-word 41
+
+SPECIAL-OBJECT: c-to-factor-word 42
+SPECIAL-OBJECT: lazy-jit-compile-word 43
+SPECIAL-OBJECT: unwind-native-frames-word 44
+
+SPECIAL-OBJECT: callback-stub 48
! PIC stubs
-USERENV: pic-load 49
-USERENV: pic-tag 50
-USERENV: pic-tuple 51
-USERENV: pic-check-tag 52
-USERENV: pic-check-tuple 53
-USERENV: pic-hit 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
+SPECIAL-OBJECT: pic-load 49
+SPECIAL-OBJECT: pic-tag 50
+SPECIAL-OBJECT: pic-tuple 51
+SPECIAL-OBJECT: pic-check-tag 52
+SPECIAL-OBJECT: pic-check-tuple 53
+SPECIAL-OBJECT: pic-hit 54
+SPECIAL-OBJECT: pic-miss-word 55
+SPECIAL-OBJECT: pic-miss-tail-word 56
! Megamorphic dispatch
-USERENV: mega-lookup 57
-USERENV: mega-lookup-word 58
-USERENV: mega-miss-word 59
+SPECIAL-OBJECT: mega-lookup 57
+SPECIAL-OBJECT: mega-lookup-word 58
+SPECIAL-OBJECT: mega-miss-word 59
! Default definition for undefined words
-USERENV: undefined-quot 60
+SPECIAL-OBJECT: undefined-quot 60
-: userenv-offset ( symbol -- n )
- userenvs get at header-size + ;
+: special-object-offset ( symbol -- n )
+ special-objects get at header-size + ;
: emit ( cell -- ) image get push ;
: fixup ( value offset -- ) image get set-nth ;
: heap-size ( -- size )
- image get length header-size - userenv-size -
+ image get length header-size - special-objects-size -
bootstrap-cells ;
: here ( -- size ) heap-size data-base + ;
0 emit ! pointer to bignum 0
0 emit ! pointer to bignum 1
0 emit ! pointer to bignum -1
- userenv-size [ f ' emit ] times ;
+ special-objects-size [ f ' emit ] times ;
-: emit-userenv ( symbol -- )
- [ get ' ] [ userenv-offset ] bi fixup ;
+: emit-special-object ( symbol -- )
+ [ get ' ] [ special-object-offset ] bi fixup ;
! Bignums
\ unwind-native-frames unwind-native-frames-word set
[ undefined ] undefined-quot set ;
-: emit-userenvs ( -- )
- userenvs get keys [ emit-userenv ] each ;
+: emit-special-objects ( -- )
+ special-objects get keys [ emit-special-object ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
emit-jit-data
"Serializing global namespace..." print flush
emit-global
- "Serializing user environment..." print flush
- emit-userenvs
+ "Serializing special object table..." print flush
+ emit-special-objects
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces assocs words.symbol ;
IN: bootstrap.image.syntax
-SYMBOL: userenvs
+SYMBOL: special-objects
-SYNTAX: RESET H{ } clone userenvs set-global ;
+SYNTAX: RESET H{ } clone special-objects set-global ;
-SYNTAX: USERENV:
+SYNTAX: SPECIAL-OBJECT:
CREATE-WORD scan-word
- [ swap userenvs get set-at ]
+ [ swap special-objects get set-at ]
[ drop define-symbol ]
2bi ;
\ No newline at end of file
M: objc-error summary ( error -- )
drop "Objective C exception" ;
-[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook
+[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
: running.app? ( -- ? )
#! Test if we're running a .app.
SYMBOL: script
SYMBOL: command-line
-: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
+: (command-line) ( -- args )
+ 10 special-object sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
{
{ kernel.private:tag [ drop emit-tag ] }
- { kernel.private:getenv [ emit-getenv ] }
+ { kernel.private:special-object [ emit-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
-: emit-getenv ( node -- )
- "userenv" ^^vm-field-ptr
+: emit-special-object ( node -- )
+ "special-objects" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;
TUPLE: callback-context ;
-: current-callback ( -- id ) 2 getenv ;
+: current-callback ( -- id ) 2 special-object ;
: wait-to-return ( token -- )
dup current-callback eq? [
: do-callback ( quot token -- )
init-catchstack
- [ 2 setenv call ] keep
+ [ 2 set-special-object call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
-[ ] [ [ 0 getenv ] compile-call drop ] unit-test
-[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
+[ ] [ [ 0 special-object ] compile-call drop ] unit-test
+[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ [ 1 drop ] compile-call ] unit-test
\ word-xt { word } { integer integer } define-primitive
\ word-xt make-flushable
-\ getenv { fixnum } { object } define-primitive
-\ getenv make-flushable
+\ special-object { fixnum } { object } define-primitive
+\ special-object make-flushable
-\ setenv { object fixnum } { } define-primitive
+\ set-special-object { object fixnum } { } define-primitive
\ (exists?) { string } { object } define-primitive
variables
sleep-entry ;
-: self ( -- thread ) 63 getenv ; inline
+: self ( -- thread ) 63 special-object ; inline
! Thread-local storage
: tnamespace ( -- assoc )
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads ( -- assoc ) 64 getenv ;
+: threads ( -- assoc ) 64 special-object ;
: thread ( id -- thread ) threads at ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
-: set-self ( thread -- ) 63 setenv ; inline
+: set-self ( thread -- ) 63 set-special-object ; inline
PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
-: run-queue ( -- dlist ) 65 getenv ;
+: run-queue ( -- dlist ) 65 special-object ;
-: sleep-queue ( -- heap ) 66 getenv ;
+: sleep-queue ( -- heap ) 66 special-object ;
: resume ( thread -- )
f >>state
<PRIVATE
: init-threads ( -- )
- H{ } clone 64 setenv
- <dlist> 65 setenv
- <min-heap> 66 setenv
+ H{ } clone 64 set-special-object
+ <dlist> 65 set-special-object
+ <min-heap> 66 set-special-object
initial-thread global
[ drop [ ] "Initial" <thread> ] cache
<box> >>continuation
'[ drop _ member? not ] assoc-filter
[ drop string? not ] assoc-filter ! strip CLI args
sift-assoc
- 21 setenv
+ 21 set-special-object
] [ drop ] if ;
: strip-c-io ( -- )
strip-c-io
strip-default-methods
strip-compiler-classes
- f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
+ f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-startup-quot
find-megamorphic-caches
stripped-word-props
: objc-error ( error -- ) die ;
-[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook
+[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
H{ } clone \ pool [
global [
-! Copyright (C) 2009 Phil Dawes.
+! Copyright (C) 2009, 2010 Phil Dawes, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
{ nursery zone }
{ cards-offset cell }
{ decks-offset cell }
-{ userenv cell[70] } ;
+{ special-objects cell[70] } ;
: vm-field-offset ( field -- offset ) vm offset-of ; inline
M: sequence string>symbol [ string>symbol* ] map ;
[
- 8 getenv utf8 alien>string string>cpu \ cpu set-global
- 9 getenv utf8 alien>string string>os \ os set-global
+ 8 special-object utf8 alien>string string>cpu \ cpu set-global
+ 9 special-object utf8 alien>string string>os \ os set-global
] "alien.strings" add-startup-hook
{ "float-u>=" "math.private" (( x y -- ? )) }
{ "(word)" "words.private" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
- { "getenv" "kernel.private" (( n -- obj )) }
- { "setenv" "kernel.private" (( obj n -- )) }
+ { "special-object" "kernel.private" (( n -- obj )) }
+ { "set-special-object" "kernel.private" (( obj n -- )) }
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
: execute-effect-unsafe ( word effect -- ) drop execute ;
-M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ;
+M: object throw
+ 5 special-object [ die ] or
+ (( error -- * )) call-effect-unsafe ;
PRIVATE>
! Incremented each time stack effects potentially changed, used
! by compiler.tree.propagation.call-effect for call( and execute(
! inline caching
-: effect-counter ( -- n ) 47 getenv ; inline
+: effect-counter ( -- n ) 47 special-object ; inline
GENERIC: bump-effect-counter* ( defspec -- ? )
or ;
: bump-effect-counter ( -- )
- bump-effect-counter? [ 47 getenv 0 or 1 + 47 setenv ] when ;
+ bump-effect-counter? [
+ 47 special-object 0 or
+ 1 +
+ 47 set-special-object
+ ] when ;
: notify-observers ( -- )
updated-definitions dup assoc-empty?
<PRIVATE
: catchstack* ( -- catchstack )
- 1 getenv { vector } declare ; inline
+ 1 special-object { vector } declare ; inline
: >c ( continuation -- ) catchstack* push ;
: dummy-1 ( -- obj ) f ;
: dummy-2 ( obj -- obj ) dup drop ;
-: init-catchstack ( -- ) V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
PRIVATE>
: catchstack ( -- catchstack ) catchstack* clone ; inline
-: set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
+: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
TUPLE: continuation data call retain name catch ;
: continue-with ( obj continuation -- * )
[
- swap 4 setenv
+ swap 4 set-special-object
>continuation<
set-catchstack
set-namestack
set-retainstack
- [ set-datastack drop 4 getenv f 4 setenv f ] dip
+ [ set-datastack drop 4 special-object f 4 set-special-object f ] dip
set-callstack
] (( obj continuation -- * )) call-effect-unsafe ;
! VM calls on error
[
! 63 = self
- 63 getenv error-thread set-global
+ 63 special-object error-thread set-global
continuation error-continuation set-global
rethrow
- ] 5 setenv
+ ] 5 set-special-object
! VM adds this to kernel errors, so that user-space
! can identify them
- "kernel-error" 6 setenv ;
+ "kernel-error" 6 set-special-object ;
PRIVATE>
: boot ( -- ) init-namespaces init-catchstack init-error-handler ;
-: startup-quot ( -- quot ) 20 getenv ;
+: startup-quot ( -- quot ) 20 special-object ;
-: set-startup-quot ( quot -- ) 20 setenv ;
+: set-startup-quot ( quot -- ) 20 set-special-object ;
-: shutdown-quot ( -- quot ) 22 getenv ;
+: shutdown-quot ( -- quot ) 22 special-object ;
-: set-shutdown-quot ( quot -- ) 22 setenv ;
+: set-shutdown-quot ( quot -- ) 22 set-special-object ;
[ do-shutdown-hooks ] set-shutdown-quot
[
cwd current-directory set-global
- 13 getenv alien>native-string cwd prepend-path \ image set-global
- 14 getenv alien>native-string cwd prepend-path \ vm set-global
+ 13 special-object alien>native-string cwd prepend-path \ image set-global
+ 14 special-object alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-startup-hook
M: c-io-backend init-io ;
-: stdin-handle ( -- alien ) 11 getenv ;
-: stdout-handle ( -- alien ) 12 getenv ;
-: stderr-handle ( -- alien ) 61 getenv ;
+: stdin-handle ( -- alien ) 11 special-object ;
+: stdout-handle ( -- alien ) 12 special-object ;
+: stderr-handle ( -- alien ) 61 special-object ;
: init-c-stdio ( -- )
stdin-handle <c-reader>
{ $values { "object" object } { "n" "a tag number" } }
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-HELP: getenv ( n -- obj )
+HELP: special-object ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }
-{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Reads an object from the Factor VM's special object table. User code never has to read the special object table directly; instead, use one of the callers of this word." } ;
-HELP: setenv ( obj n -- )
+HELP: set-special-object ( obj n -- )
{ $values { "obj" object } { "n" "a non-negative integer" } }
-{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Writes an object to the Factor VM's special object table. User code never has to write to the special object table directly; instead, use one of the callers of this word." } ;
HELP: object
{ $class-description
! We do this in its own compilation unit so that they can be
! folded below
<<
-: cell ( -- n ) 7 getenv ; foldable
+: cell ( -- n ) 7 special-object ; foldable
: (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
>>
<PRIVATE
-: namestack* ( -- namestack ) 0 getenv { vector } declare ; inline
+: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
-: set-namestack ( namestack -- ) >vector 0 setenv ;
-: global ( -- g ) 21 getenv { hashtable } declare ; inline
+: set-namestack ( namestack -- ) >vector 0 set-special-object ;
+: global ( -- g ) 21 special-object { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; inline
: set ( value variable -- ) namespace set-at ;
: vm ( -- path ) \ vm get-global ;
-: embedded? ( -- ? ) 15 getenv ;
+: embedded? ( -- ? ) 15 special-object ;
: exit ( n -- ) do-shutdown-hooks (exit) ;