Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2008-11-09 17:22:45 -08:00
commit 6049918ddc
26 changed files with 256 additions and 152 deletions

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.parser sequences accessors USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays sets threads libc continuations.private alien.strings alien.arrays sets threads libc continuations.private
@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- ) GENERIC: inc-reg-class ( register-class -- )
M: reg-class inc-reg-class : ?dummy-stack-params ( reg-class -- )
dup reg-class-variable inc dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( reg-class -- )
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
: ?dummy-fp-params ( reg-class -- )
drop dummy-fp-params? [ float-regs inc ] when ;
M: int-regs inc-reg-class
[ reg-class-variable inc ]
[ ?dummy-stack-params ]
[ ?dummy-fp-params ]
tri ;
M: float-regs inc-reg-class M: float-regs inc-reg-class
dup call-next-method [ reg-class-variable inc ]
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; [ ?dummy-stack-params ]
[ ?dummy-int-params ]
tri ;
GENERIC: reg-class-full? ( class -- ? ) GENERIC: reg-class-full? ( class -- ? )

View File

@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass value structs by value or hidden reference? ! Do we pass value structs by value or hidden reference?
HOOK: value-structs? cpu ( -- ? ) HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters ! If t, all parameters are shadowed by dummy stack parameters
HOOK: fp-shadows-int? cpu ( -- ? ) HOOK: dummy-stack-params? cpu ( -- ? )
! If t, all FP parameters are shadowed by dummy int parameters
HOOK: dummy-int-params? cpu ( -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
HOOK: %prepare-unbox cpu ( -- ) HOOK: %prepare-unbox cpu ( -- )

View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; USING: accessors system kernel layouts
alien.c-types cpu.architecture cpu.ppc ;
IN: cpu.ppc.linux IN: cpu.ppc.linux
<< <<
@ -8,12 +9,16 @@ t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type (>>stack-align?) t "ulonglong" c-type (>>stack-align?)
>> >>
M: linux reserved-area-size 2 ; M: linux reserved-area-size 2 cells ;
M: linux lr-save 1 ; M: linux lr-save 1 cells ;
M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
M: ppc value-structs? drop f ; M: ppc value-structs? f ;
M: ppc fp-shadows-int? drop f ; M: ppc dummy-stack-params? f ;
M: ppc dummy-int-params? f ;
M: ppc dummy-fp-params? f ;

View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ; USING: accessors system kernel layouts
alien.c-types cpu.architecture cpu.ppc ;
IN: cpu.ppc.macosx IN: cpu.ppc.macosx
<< <<
@ -9,12 +10,16 @@ IN: cpu.ppc.macosx
4 "double" c-type (>>align) 4 "double" c-type (>>align)
>> >>
M: macosx reserved-area-size 6 ; M: macosx reserved-area-size 6 cells ;
M: macosx lr-save 2 ; M: macosx lr-save 2 cells ;
M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: ppc value-structs? drop t ; M: ppc value-structs? t ;
M: ppc fp-shadows-int? drop t ; M: ppc dummy-stack-params? t ;
M: ppc dummy-int-params? t ;
M: ppc dummy-fp-params? f ;

View File

@ -349,12 +349,17 @@ M: ppc %gc
"end" resolve-label ; "end" resolve-label ;
M: ppc %prologue ( n -- ) M: ppc %prologue ( n -- )
0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this #! We use a volatile register (r11) here for scratch. Because
#! callback bodies have a prologue too, we cannot assume
#! that c_to_factor saved all non-volatile registers, so
#! we have to respect the C calling convention. Also, we
#! cannot touch any param-regs either.
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR 0 MFLR
1 1 pick neg ADDI 1 1 pick neg ADDI
scratch-reg 1 pick xt-save STW 11 1 pick xt-save STW
dup scratch-reg LI dup 11 LI
scratch-reg 1 pick next-save STW 11 1 pick next-save STW
0 1 rot lr-save + STW ; 0 1 rot lr-save + STW ;
M: ppc %epilogue ( n -- ) M: ppc %epilogue ( n -- )

View File

@ -274,6 +274,12 @@ M: x86.32 %callback-return ( n -- )
[ drop 0 ] [ drop 0 ]
} cond RET ; } cond RET ;
M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-int-params? f ;
M: x86.32 dummy-fp-params? f ;
os windows? [ os windows? [
cell "longlong" c-type (>>align) cell "longlong" c-type (>>align)
cell "ulonglong" c-type (>>align) cell "ulonglong" c-type (>>align)

View File

@ -26,6 +26,7 @@ M: x86.64 temp-reg-2 RCX ;
: param-reg-1 int-regs param-regs first ; inline : param-reg-1 int-regs param-regs first ; inline
: param-reg-2 int-regs param-regs second ; inline : param-reg-2 int-regs param-regs second ; inline
: param-reg-3 int-regs param-regs third ; inline
M: int-regs return-reg drop RAX ; M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ; M: float-regs return-reg drop XMM0 ;
@ -40,13 +41,13 @@ M: x86.64 %prologue ( n -- )
M: stack-params %load-param-reg M: stack-params %load-param-reg
drop drop
>r R11 swap stack@ MOV >r R11 swap param@ MOV
r> stack@ R11 MOV ; r> param@ R11 MOV ;
M: stack-params %save-param-reg M: stack-params %save-param-reg
drop drop
R11 swap next-stack@ MOV R11 swap next-stack@ MOV
stack@ R11 MOV ; param@ R11 MOV ;
: with-return-regs ( quot -- ) : with-return-regs ( quot -- )
[ [
@ -55,37 +56,6 @@ M: stack-params %save-param-reg
call call
] with-scope ; inline ] with-scope ; inline
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- ) M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack ! First parameter is top of stack
param-reg-1 R14 [] MOV param-reg-1 R14 [] MOV
@ -102,7 +72,7 @@ M: x86.64 %unbox-long-long ( n func -- )
: %unbox-struct-field ( c-type i -- ) : %unbox-struct-field ( c-type i -- )
! Alien must be in param-reg-1. ! Alien must be in param-reg-1.
param-reg-1 swap cells [+] swap reg-class>> { R11 swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] } { int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] } { double-float-regs [ float-regs get pop swap MOVSD ] }
} case ; } case ;
@ -110,20 +80,20 @@ M: x86.64 %unbox-long-long ( n func -- )
M: x86.64 %unbox-small-struct ( c-type -- ) M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-1. ! Alien must be in param-reg-1.
"alien_offset" f %alien-invoke "alien_offset" f %alien-invoke
! Move alien_offset() return value to param-reg-1 so that we don't ! Move alien_offset() return value to R11 so that we don't
! clobber it. ! clobber it.
param-reg-1 RAX MOV R11 RAX MOV
[ [
flatten-small-struct [ %unbox-struct-field ] each-index flatten-value-type [ %unbox-struct-field ] each-index
] with-return-regs ; ] with-return-regs ;
M: x86.64 %unbox-large-struct ( n c-type -- ) M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in param-reg-1 ! Source is in param-reg-1
heap-size heap-size
! Load destination address ! Load destination address
param-reg-2 rot stack@ LEA param-reg-2 rot param@ LEA
! Load structure size ! Load structure size
RDX swap MOV param-reg-3 swap MOV
! Copy the struct to the C stack ! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ; "to_value_struct" f %alien-invoke ;
@ -142,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- )
M: x86.64 %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ; int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) : box-struct-field@ ( i -- operand ) 1+ cells param@ ;
heap-size 2 cells <= ;
: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
: %box-struct-field ( c-type i -- ) : %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> { box-struct-field@ swap reg-class>> {
@ -156,15 +123,15 @@ M: x86.64 struct-small-enough? ( size -- ? )
M: x86.64 %box-small-struct ( c-type -- ) M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct. #! Box a <= 16-byte struct.
[ [
[ flatten-small-struct [ %box-struct-field ] each-index ] [ flatten-value-type [ %box-struct-field ] each-index ]
[ RDX swap heap-size MOV ] bi [ param-reg-3 swap heap-size MOV ] bi
param-reg-1 0 box-struct-field@ MOV param-reg-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke "box_small_struct" f %alien-invoke
] with-return-regs ; ] with-return-regs ;
: struct-return@ ( n -- operand ) : struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* stack@ ; [ stack-frame get params>> ] unless* param@ ;
M: x86.64 %box-large-struct ( n c-type -- ) M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2 ! Struct size is parameter 2
@ -178,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return ! Compute target address for value struct return
RAX f struct-return@ LEA RAX f struct-return@ LEA
! Store it as the first parameter ! Store it as the first parameter
0 stack@ RAX MOV ; 0 param@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ; M: x86.64 %prepare-var-args RAX RAX XOR ;

View File

@ -1,7 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system compiler.cfg.registers USING: accessors arrays sequences math splitting make assocs
cpu.architecture cpu.x86.assembler cpu.x86 ; kernel layouts system alien.c-types alien.structs
cpu.architecture cpu.x86.assembler cpu.x86
compiler.codegen compiler.cfg.registers ;
IN: cpu.x86.64.unix IN: cpu.x86.64.unix
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
@ -10,3 +12,43 @@ M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 reserved-area-size 0 ; M: x86.64 reserved-area-size 0 ;
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ;
M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system alien.c-types compiler.cfg.registers USING: kernel layouts system math alien.c-types
cpu.architecture cpu.x86.assembler cpu.x86 ; compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
IN: cpu.x86.64.winnt IN: cpu.x86.64.winnt
M: int-regs param-regs drop { RCX RDX R8 R9 } ; M: int-regs param-regs drop { RCX RDX R8 R9 } ;
@ -10,6 +10,15 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-area-size 4 cells ; M: x86.64 reserved-area-size 4 cells ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size cell <= ;
M: x86.64 dummy-stack-params? f ;
M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ;
<< <<
"longlong" "ptrdiff_t" typedef "longlong" "ptrdiff_t" typedef
"int" "long" typedef "int" "long" typedef

View File

@ -467,6 +467,8 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
: stack@ ( n -- op ) stack-reg swap [+] ; : stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: spill-integer-base ( stack-frame -- n ) : spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + reserved-area-size + ; [ params>> ] [ return>> ] bi + reserved-area-size + ;
@ -493,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %save-param-reg drop >r param@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ; M: int-regs %load-param-reg drop swap param@ MOV ;
GENERIC: MOVSS/D ( dst src reg-class -- ) GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ; M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ; M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- ) GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( n reg-class -- ) GENERIC: load-return-reg ( n reg-class -- )
@ -518,8 +520,6 @@ M: x86 %prepare-alien-invoke
temp-reg-1 2 cells [+] ds-reg MOV temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ; temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86 value-structs? t ; M: x86 value-structs? t ;
M: x86 small-enough? ( n -- ? ) M: x86 small-enough? ( n -- ? )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math USING: kernel sequences combinators parser splitting math
quotations arrays make qualified words ; quotations arrays make words ;
IN: fry IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ; : _ ( -- * ) "Only valid inside a fry" throw ;

2
basis/io/windows/files/files.factor Normal file → Executable file
View File

@ -276,7 +276,7 @@ M: winnt file-system-info ( path -- file-system-info )
swap >>type swap >>type
swap >>mount-point ; swap >>mount-point ;
: find-first-volume ( word -- string handle ) : find-first-volume ( -- string handle )
MAX_PATH 1+ <byte-array> dup length MAX_PATH 1+ <byte-array> dup length
dupd dupd
FindFirstVolume dup win32-error=0/f FindFirstVolume dup win32-error=0/f

View File

@ -32,3 +32,14 @@ HELP: RENAME:
"RENAME: + math => -" "RENAME: + math => -"
"2 3 - ! => 5" } } ; "2 3 - ! => 5" } } ;
ARTICLE: "qualified" "Qualified word lookup"
"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
$nl
"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
{ $subsection POSTPONE: QUALIFIED: }
{ $subsection POSTPONE: QUALIFIED-WITH: }
{ $subsection POSTPONE: FROM: }
{ $subsection POSTPONE: EXCLUDE: }
{ $subsection POSTPONE: RENAME: } ;
ABOUT: "qualified"

View File

@ -1,24 +1,33 @@
USING: tools.test qualified ; USING: tools.test qualified eval accessors parser ;
IN: foo IN: qualified.tests.foo
: x 1 ; : x 1 ;
IN: bar : y 5 ;
IN: qualified.tests.bar
: x 2 ; : x 2 ;
IN: baz : y 4 ;
IN: qualified.tests.baz
: x 3 ; : x 3 ;
QUALIFIED: foo QUALIFIED: qualified.tests.foo
QUALIFIED: bar QUALIFIED: qualified.tests.bar
[ 1 2 3 ] [ foo:x bar:x x ] unit-test [ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
QUALIFIED-WITH: bar p QUALIFIED-WITH: qualified.tests.bar p
[ 2 ] [ p:x ] unit-test [ 2 ] [ p:x ] unit-test
RENAME: x baz => y RENAME: x qualified.tests.baz => y
[ 3 ] [ y ] unit-test [ 3 ] [ y ] unit-test
FROM: baz => x ; FROM: qualified.tests.baz => x ;
[ 3 ] [ x ] unit-test [ 3 ] [ x ] unit-test
[ 3 ] [ y ] unit-test
EXCLUDE: bar => x ; EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test [ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
[ error>> no-word-error? ] must-fail-with
[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
[ error>> no-word-error? ] must-fail-with

View File

@ -1,12 +1,12 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg. ! Copyright (C) 2007, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences assocs hashtables parser lexer USING: kernel sequences assocs hashtables parser lexer
vocabs words namespaces vocabs.loader debugger sets ; vocabs words namespaces vocabs.loader debugger sets fry ;
IN: qualified IN: qualified
: define-qualified ( vocab-name prefix-name -- ) : define-qualified ( vocab-name prefix-name -- )
[ load-vocab vocab-words ] [ CHAR: : suffix ] bi* [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
[ -rot >r append r> ] curry assoc-map '[ [ [ _ ] dip append ] dip ] assoc-map
use get push ; use get push ;
: QUALIFIED: : QUALIFIED:
@ -19,27 +19,27 @@ IN: qualified
: expect=> ( -- ) scan "=>" assert= ; : expect=> ( -- ) scan "=>" assert= ;
: partial-vocab ( words name -- assoc ) : partial-vocab ( words vocab -- assoc )
dupd [ '[ dup _ lookup [ no-word-error ] unless* ]
lookup [ "No such word: " swap append throw ] unless* { } map>assoc ;
] curry map zip ;
: partial-vocab-ignoring ( words name -- assoc )
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
scan expect=>
";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
: FROM: : FROM:
#! Syntax: FROM: vocab => words... ; #! Syntax: FROM: vocab => words... ;
scan dup load-vocab drop expect=> scan dup load-vocab drop expect=>
";" parse-tokens swap partial-vocab use get push ; parsing ";" parse-tokens swap partial-vocab use get push ; parsing
: partial-vocab-excluding ( words vocab -- assoc )
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
scan expect=>
";" parse-tokens swap partial-vocab-excluding use get push ; parsing
: RENAME: : RENAME:
#! Syntax: RENAME: word vocab => newname #! Syntax: RENAME: word vocab => newname
scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* scan scan dup load-vocab drop
dupd lookup [ ] [ no-word-error ] ?if
expect=> expect=>
scan associate use get push ; parsing scan associate use get push ; parsing

View File

@ -9,16 +9,14 @@ IN: tools.deploy.windows
"resource:factor.dll" swap copy-file-into ; "resource:factor.dll" swap copy-file-into ;
: copy-freetype ( bundle-name -- ) : copy-freetype ( bundle-name -- )
deploy-ui? get [
{ {
"resource:freetype6.dll" "resource:freetype6.dll"
"resource:zlib1.dll" "resource:zlib1.dll"
} swap copy-files-into } swap copy-files-into ;
] [ drop ] if ;
: create-exe-dir ( vocab bundle-name -- vm ) : create-exe-dir ( vocab bundle-name -- vm )
deploy-ui? get [
dup copy-dll dup copy-dll
deploy-ui? get [
dup copy-freetype dup copy-freetype
dup "" copy-fonts dup "" copy-fonts
] when ] when
@ -26,14 +24,14 @@ IN: tools.deploy.windows
M: winnt deploy* M: winnt deploy*
"resource:" [ "resource:" [
deploy-name over deploy-config at dup deploy-config [
deploy-name get
[ [
{
[ create-exe-dir ] [ create-exe-dir ]
[ image-name ] [ image-name ]
[ drop ] [ drop ]
[ drop deploy-config ] 2tri namespace make-deploy-image
} 2cleave make-deploy-image
] ]
[ nip open-in-explorer ] 2bi [ nip open-in-explorer ] 2bi
] bind
] with-directory ; ] with-directory ;

View File

@ -271,17 +271,21 @@ check_os_arch_word() {
set_build_info() { set_build_info() {
check_os_arch_word check_os_arch_word
MAKE_TARGET=$OS-$ARCH-$WORD
if [[ $OS == macosx && $ARCH == ppc ]] ; then if [[ $OS == macosx && $ARCH == ppc ]] ; then
MAKE_IMAGE_TARGET=macosx-ppc MAKE_IMAGE_TARGET=macosx-ppc
MAKE_TARGET=macosx-ppc
elif [[ $OS == linux && $ARCH == ppc ]] ; then elif [[ $OS == linux && $ARCH == ppc ]] ; then
MAKE_IMAGE_TARGET=linux-ppc MAKE_IMAGE_TARGET=linux-ppc
MAKE_TARGET=linux-ppc
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_IMAGE_TARGET=winnt-x86.64
MAKE_TARGET=winnt-x86-64
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=unix-x86.64 MAKE_IMAGE_TARGET=unix-x86.64
MAKE_TARGET=$OS-x86-64
else else
MAKE_IMAGE_TARGET=$ARCH.$WORD MAKE_IMAGE_TARGET=$ARCH.$WORD
MAKE_TARGET=$OS-$ARCH-$WORD
fi fi
BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
} }

View File

@ -69,7 +69,7 @@ $nl
{ $subsection POSTPONE: PRIVATE> } { $subsection POSTPONE: PRIVATE> }
{ $subsection "vocabulary-search-errors" } { $subsection "vocabulary-search-errors" }
{ $subsection "vocabulary-search-shadow" } { $subsection "vocabulary-search-shadow" }
{ $see-also "words" } ; { $see-also "words" "qualified" } ;
ARTICLE: "reading-ahead" "Reading ahead" ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:" "Parsing words can consume input:"

View File

@ -71,10 +71,10 @@ ERROR: no-current-vocab ;
] keep ] keep
] { } map>assoc ; ] { } map>assoc ;
TUPLE: no-word-error name ; ERROR: no-word-error name ;
: no-word ( name -- newword ) : no-word ( name -- newword )
dup no-word-error boa dup \ no-word-error boa
swap words-named [ forward-reference? not ] filter swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts word-restarts throw-restarts
dup vocabulary>> (use+) ; dup vocabulary>> (use+) ;

View File

@ -5,7 +5,7 @@ USING: alien arrays byte-arrays combinators summary
io.backend graphics.viewer io io.binary io.files kernel libc io.backend graphics.viewer io io.binary io.files kernel libc
math math.functions namespaces opengl opengl.gl prettyprint math math.functions namespaces opengl opengl.gl prettyprint
sequences strings ui ui.gadgets.panes io.encodings.binary sequences strings ui ui.gadgets.panes io.encodings.binary
accessors ; accessors grouping ;
IN: graphics.bitmap IN: graphics.bitmap
! Currently can only handle 24bit bitmaps. ! Currently can only handle 24bit bitmaps.
@ -23,16 +23,25 @@ TUPLE: bitmap magic size reserved offset header-length width
swap [ >>array ] [ >>color-index ] bi swap [ >>array ] [ >>color-index ] bi
24 >>bit-count ; 24 >>bit-count ;
: raw-bitmap>string ( str n -- str ) : 8bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: 4bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{ {
{ 32 [ "32bit" throw ] } { 32 [ "32bit" throw ] }
{ 24 [ ] } { 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] } { 16 [ "16bit" throw ] }
{ 8 [ "8bit" throw ] } { 8 [ 8bit>array ] }
{ 4 [ "4bit" throw ] } { 4 [ 4bit>array ] }
{ 2 [ "2bit" throw ] } { 2 [ "2bit" throw ] }
{ 1 [ "1bit" throw ] } { 1 [ "1bit" throw ] }
} case ; } case >byte-array ;
ERROR: bitmap-magic ; ERROR: bitmap-magic ;
@ -72,13 +81,12 @@ M: bitmap-magic summary
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
normalize-path binary [ normalize-path binary [
T{ bitmap } clone bitmap new
dup parse-file-header dup parse-file-header
dup parse-bitmap-header dup parse-bitmap-header
dup parse-bitmap dup parse-bitmap
] with-file-reader ] with-file-reader
dup color-index>> over bit-count>> dup raw-bitmap>array >>array ;
raw-bitmap>string >byte-array >>array ;
: save-bitmap ( bitmap path -- ) : save-bitmap ( bitmap path -- )
binary [ binary [
@ -118,6 +126,8 @@ M: bitmap draw-image ( bitmap -- )
bit-count>> { bit-count>> {
! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] } { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case } case
] keep array>> glDrawPixels ; ] keep array>> glDrawPixels ;

View File

@ -6,3 +6,6 @@ USING: hexdump kernel sequences tools.test ;
[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test [ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
[
"Length: 3, 3h\n00000000h: 01 02 03 ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test

View File

@ -21,9 +21,9 @@ IN: hexdump
[ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ; [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
: >ascii ( bytes -- str ) : >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] map ; [ [ printable? ] keep CHAR: . ? ] "" map-as ;
: write-hex-line ( str lineno -- ) : write-hex-line ( bytes lineno -- )
write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
PRIVATE> PRIVATE>

View File

@ -117,7 +117,7 @@ CELL frame_executing(F_STACK_FRAME *frame)
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame) F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
{ {
if(frame->size == 0) if(frame->size == 0)
critical_error("Stack frame has zero size",frame); critical_error("Stack frame has zero size",(CELL)frame);
return (F_STACK_FRAME *)((CELL)frame - frame->size); return (F_STACK_FRAME *)((CELL)frame - frame->size);
} }

View File

@ -10,14 +10,18 @@ and the callstack top is passed in EDX */
#define DS_REG %esi #define DS_REG %esi
#define RETURN_REG %eax #define RETURN_REG %eax
#define NV_TEMP_REG %ebx
#define CELL_SIZE 4 #define CELL_SIZE 4
#define STACK_PADDING 12 #define STACK_PADDING 12
#define PUSH_NONVOLATILE \ #define PUSH_NONVOLATILE \
push %ebx ; \ push %ebx ; \
push %ebp ; \
push %ebp push %ebp
#define POP_NONVOLATILE \ #define POP_NONVOLATILE \
pop %ebp ; \
pop %ebp ; \ pop %ebp ; \
pop %ebx pop %ebx

View File

@ -7,6 +7,8 @@
#define CELL_SIZE 8 #define CELL_SIZE 8
#define STACK_PADDING 56 #define STACK_PADDING 56
#define NV_TEMP_REG %rbp
#ifdef WINDOWS #ifdef WINDOWS
#define ARG0 %rcx #define ARG0 %rcx
@ -20,9 +22,11 @@
push %rdi ; \ push %rdi ; \
push %rsi ; \ push %rsi ; \
push %rbx ; \ push %rbx ; \
push %rbp ; \
push %rbp push %rbp
#define POP_NONVOLATILE \ #define POP_NONVOLATILE \
pop %rbp ; \
pop %rbp ; \ pop %rbp ; \
pop %rbx ; \ pop %rbx ; \
pop %rsi ; \ pop %rsi ; \
@ -41,9 +45,11 @@
push %rbx ; \ push %rbx ; \
push %rbp ; \ push %rbp ; \
push %r12 ; \ push %r12 ; \
push %r13 ; \
push %r13 push %r13
#define POP_NONVOLATILE \ #define POP_NONVOLATILE \
pop %r13 ; \
pop %r13 ; \ pop %r13 ; \
pop %r12 ; \ pop %r12 ; \
pop %rbp ; \ pop %rbp ; \

View File

@ -1,20 +1,21 @@
DEF(F_FASTCALL void,c_to_factor,(CELL quot)): DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE PUSH_NONVOLATILE
push ARG0 mov ARG0,NV_TEMP_REG
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
/* Create register shadow area for Win64 */ /* Create register shadow area for Win64 */
sub $32,STACK_REG sub $32,STACK_REG
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
call MANGLE(save_callstack_bottom) call MANGLE(save_callstack_bottom)
add $32,STACK_REG
/* Call quot-xt */ /* Call quot-xt */
mov (STACK_REG),ARG0 mov NV_TEMP_REG,ARG0
call *QUOT_XT_OFFSET(ARG0) call *QUOT_XT_OFFSET(ARG0)
pop ARG0 /* Tear down register shadow area */
add $32,STACK_REG
POP_NONVOLATILE POP_NONVOLATILE
ret ret