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

db4
sheeple 2008-11-10 03:02:17 -06:00
commit 067e9934e1
32 changed files with 167 additions and 772 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

@ -17,4 +17,8 @@ M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
M: ppc value-structs? f ; M: ppc value-structs? f ;
M: ppc fp-shadows-int? f ; M: ppc dummy-stack-params? f ;
M: ppc dummy-int-params? f ;
M: ppc dummy-fp-params? f ;

View File

@ -18,4 +18,8 @@ M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: ppc value-structs? t ; M: ppc value-structs? t ;
M: ppc fp-shadows-int? t ; M: ppc dummy-stack-params? t ;
M: ppc dummy-int-params? t ;
M: ppc dummy-fp-params? f ;

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 -- ? )

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

@ -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 )
dup copy-dll
deploy-ui? get [ deploy-ui? get [
dup copy-dll
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

@ -4,7 +4,8 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose models models.range models.compose
combinators math.vectors classes.tuple math.geometry.rect ; combinators math.vectors classes.tuple math.geometry.rect
combinators.short-circuit ;
IN: ui.gadgets.scrollers IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ; TUPLE: scroller < frame viewport x y follows ;
@ -70,13 +71,10 @@ scroller H{
: relative-scroll-rect ( rect gadget scroller -- newrect ) : relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ; viewport>> gadget-child relative-loc offset-rect ;
: find-scroller* ( gadget -- scroller ) : find-scroller* ( gadget -- scroller/f )
dup find-scroller dup [ dup find-scroller
2dup viewport>> gadget-child { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
swap child? [ nip ] [ 2drop f ] if 2&& ;
] [
2drop f
] if ;
: scroll>rect ( rect gadget -- ) : scroll>rect ( rect gadget -- )
dup find-scroller* dup [ dup find-scroller* dup [

View File

@ -1,46 +0,0 @@
USING: io.files io.launcher io.encodings.utf8 prettyprint
builder.util builder.common builder.child builder.release
builder.report builder.email builder.cleanup ;
IN: builder.build
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enter-build-dir ( -- ) build-dir set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-id ( -- )
"factor"
[ git-id "../git-id" utf8 [ . ] with-file-writer ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build ( -- )
reset-status
create-build-dir
enter-build-dir
clone-builds-factor
record-id
build-child
release
report
email-report
cleanup ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build

View File

@ -1,21 +0,0 @@
USING: kernel debugger io.files threads calendar
builder.common
builder.updates
builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build-loop ( -- )
builds-check
[
builds/factor set-current-directory
new-code-available? [ build ] when
]
try
5 minutes sleep
build-loop ;
MAIN: build-loop

View File

@ -1,68 +0,0 @@
USING: namespaces debugger io.files io.launcher accessors bootstrap.image
calendar builder.util builder.common ;
IN: builder.child
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-vm ( -- )
<process>
gnu-make >>command
"../compile-log" >>stdout
+stdout+ >>stderr
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
: copy-image ( -- )
builds-factor-image ".." copy-file-into
builds-factor-image "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: boot ( -- )
<process>
boot-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
: test ( -- )
<process>
test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
240 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build-child) ( -- )
make-clean
make-vm status-vm on
copy-image
boot status-boot on
test status-test on
status on ;
: build-child ( -- )
"factor" set-current-directory
[ (build-child) ] try
".." set-current-directory ;

View File

@ -1,26 +0,0 @@
USING: kernel namespaces io.files io.launcher bootstrap.image
builder.util builder.common ;
IN: builder.cleanup
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-debug
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )
build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
: cleanup ( -- )
builder-debug get f =
[
"test-log" delete-file
delete-child-factor
compress-image
]
when ;

View File

@ -1,54 +0,0 @@
USING: kernel namespaces sequences splitting
io io.files io.launcher io.encodings.utf8 prettyprint
vars builder.util ;
IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builds-dir
: builds ( -- path )
builds-dir get
home "/builds" append
or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: stamp
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: status-vm
SYMBOL: status-boot
SYMBOL: status-test
SYMBOL: status-build
SYMBOL: status-release
SYMBOL: status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reset-status ( -- )
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;

View File

@ -1,24 +0,0 @@
USING: kernel namespaces accessors smtp builder.util builder.common ;
IN: builder.email
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
: email-report ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"report" file>string >>body
send-email ;

View File

@ -1,69 +0,0 @@
USING: kernel combinators system sequences io.files io.launcher prettyprint
builder.util
builder.common ;
IN: builder.release.archive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: base-name ( -- string )
{ "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
: extension ( -- extension )
{
{ [ os winnt? ] [ ".zip" ] }
{ [ os macosx? ] [ ".dmg" ] }
{ [ os unix? ] [ ".tar.gz" ] }
}
cond ;
: archive-name ( -- string ) base-name extension append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
! : macosx-archive-cmd ( -- cmd )
! { "hdiutil" "create"
! "-srcfolder" "factor"
! "-fs" "HFS+"
! "-volname" "factor"
! archive-name } ;
: macosx-archive-cmd ( -- cmd )
{ "mkdir" "dmg-root" } try-process
{ "cp" "-r" "factor" "dmg-root" } try-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor"
archive-name } to-strings try-process
{ "rm" "-rf" "dmg-root" } try-process
{ "true" } ;
: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: archive-cmd ( -- cmd )
{
{ [ os windows? ] [ windows-archive-cmd ] }
{ [ os macosx? ] [ macosx-archive-cmd ] }
{ [ os unix? ] [ unix-archive-cmd ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-archive ( -- ) archive-cmd to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path )
builds "releases" append-path
dup exists? not
[ dup make-directory ]
when ;
: save-archive ( -- ) archive-name releases move-file-into ;

View File

@ -1,40 +0,0 @@
USING: kernel system namespaces sequences prettyprint io.files io.launcher
bootstrap.image
builder.util
builder.common ;
IN: builder.release.branch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: branch-name ( -- string ) "clean-" platform append ;
: refspec ( -- string ) "master:" branch-name append ;
: push-to-clean-branch ( -- )
{ "git" "push" "factorcode.org:/git/factor.git" refspec }
to-strings
try-process ;
: upload-clean-image ( -- )
{
"scp"
my-boot-image-name
{ "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
}
to-strings
try-process ;
: (update-clean-branch) ( -- )
"factor"
[
push-to-clean-branch
upload-clean-image
]
with-directory ;
: update-clean-branch ( -- )
upload-to-factorcode get
[ (update-clean-branch) ]
when ;

View File

@ -1,27 +0,0 @@
USING: kernel debugger system namespaces sequences splitting combinators
io io.files io.launcher prettyprint bootstrap.image
combinators.cleave
builder.util
builder.common
builder.release.branch
builder.release.tidy
builder.release.archive
builder.release.upload ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (release) ( -- )
update-clean-branch
tidy
make-archive
upload
save-archive
status-release on ;
: clean-build? ( -- ? )
{ "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
: release ( -- ) [ clean-build? [ (release) ] when ] try ;

View File

@ -1,29 +0,0 @@
USING: kernel system io.files io.launcher builder.util ;
IN: builder.release.tidy
: common-files ( -- seq )
{
"boot.x86.32.image"
"boot.x86.64.image"
"boot.macosx-ppc.image"
"boot.linux-ppc.image"
"vm"
"temp"
"logs"
".git"
".gitignore"
"Makefile"
"unmaintained"
"build-support"
} ;
: remove-common-files ( -- )
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;

View File

@ -1,54 +0,0 @@
USING: kernel namespaces make sequences arrays io io.files
builder.util
builder.common
builder.release.archive ;
IN: builder.release.upload
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-host
SYMBOL: upload-username
SYMBOL: upload-directory
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-location ( -- dest )
upload-directory get platform append ;
: remote-archive-name ( -- dest )
remote-location "/" archive-name 3append ;
: temp-archive-name ( -- dest )
remote-archive-name ".incomplete" append ;
: upload-command ( -- args )
"scp"
archive-name
[ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make
3array ;
: rename-command ( -- args )
[
"ssh" ,
upload-host get ,
"-l" ,
upload-username get ,
"mv" ,
temp-archive-name ,
remote-archive-name ,
] { } make ;
: upload-temp-file ( -- )
upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ;
: rename-temp-file ( -- )
rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ;
: upload ( -- )
upload-to-factorcode get
[ upload-temp-file rename-temp-file ]
when ;

View File

@ -1,35 +0,0 @@
USING: kernel namespaces debugger system io io.files io.sockets
io.encodings.utf8 prettyprint benchmark
builder.util builder.common ;
IN: builder.report
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (report) ( -- )
"Build machine: " write host-name print
"CPU: " write cpu .
"OS: " write os .
"Build directory: " write build-dir print
"git id: " write "git-id" eval-file print nl
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
status-boot get f = [ "boot-log" 100 cat-n "Boot error" throw ] when
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks. ;
: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;

View File

@ -1,35 +0,0 @@
USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint
help.lint
benchmark
tools.time
bootstrap.stage2
tools.test tools.vocabs
builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
: do-tests ( -- )
run-all-tests
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
: do-benchmarks ( -- )
run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
: do-all ( -- )
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
[ do-load ] benchmark "../load-time" utf8 [ . ] with-file-writer
[ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
do-help-lint
do-benchmarks ;
MAIN: do-all

View File

@ -1,31 +0,0 @@
USING: kernel io.launcher bootstrap.image bootstrap.image.download
builder.util builder.common ;
IN: builder.updates
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull-cmd try-process
git-id
= not ;
: new-image-available? ( -- ? )
my-boot-image-name need-new-image?
[ download-my-image t ]
[ f ]
if ;
: new-code-available? ( -- ? )
updates-available?
new-image-available?
or ;

View File

@ -1,106 +0,0 @@
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
system
combinators sequences splitting quotations arrays strings tools.time
sequences.deep accessors assocs.lib
io.encodings.utf8
combinators.cleave calendar calendar.format eval ;
IN: builder.util
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: file>string ( file -- string ) utf8 file-contents ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: to-strings
: to-string ( obj -- str )
dup class
{
{ \ string [ ] }
{ \ quotation [ call ] }
{ \ word [ execute ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
case ;
: to-strings ( seq -- str )
dup [ string? ] all?
[ ]
[ [ to-string ] map flatten ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
now
{ year>> month>> day>> hour>> minute>> } <arr>
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) utf8 file-contents eval ;
: cat ( file -- ) utf8 file-contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] compose ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: bootstrap.image bootstrap.image.download io.streams.null ;
: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
: maybe-tail* ( seq n -- seq )
2dup longer?
[ tail* ]
[ drop ]
if ;
: cat-n ( file n -- )
[ utf8 file-lines ] [ ] bi*
maybe-tail*
[ print ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: prettyprint
: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
" " split second ;

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,7 +10,7 @@ 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 %rbx #define NV_TEMP_REG %ebx
#define CELL_SIZE 4 #define CELL_SIZE 4
#define STACK_PADDING 12 #define STACK_PADDING 12