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

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

release
Eduardo Cavazos 2007-10-10 00:21:20 -05:00
parent bcb1e8f4c7 9072011c32
commit 959b22e0d6
51 changed files with 493 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
core/alien/compiler/compiler.factor
View File

@ -27,11 +27,11 @@ GENERIC: alien-node-abi ( node -- str )
: alien-node-return* ( node -- ctype )
alien-node-return dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if
align
dup r> - ;
over >r c-type-stack-align align dup r> - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.
@ -91,24 +91,33 @@ M: float-regs inc-reg-class
[ dup class get swap inc-reg-class ] keep ;
: alloc-parameter ( parameter -- reg reg-class )
c-type c-type-reg-class dup reg-class-full?
c-type-reg-class dup reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" <repetition> % ;
cell /i "void*" c-type <repetition> % ;
: flatten-int-type ( n type -- n )
[ parameter-align (flatten-int-type) ] keep
stack-size cell align dup (flatten-int-type) + ;
GENERIC: flatten-value-type ( type -- )
: flatten-value-type ( n type -- n )
dup c-type c-type-reg-class T{ int-regs } =
[ flatten-int-type ] [ , ] if ;
M: object flatten-value-type , ;
M: struct-type flatten-value-type ( type -- )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[ 0 [ flatten-value-type ] reduce drop ] { } make ;
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ stack-size cell align + ] keep
flatten-value-type
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
@ -127,11 +136,11 @@ M: float-regs inc-reg-class
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
swap
>r
alien-node-parameters*
flatten-value-types
[ pick >r alloc-parameter r> execute ] each-parameter
drop ; inline
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
inline
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline

3
core/bootstrap/primitives.factor
View File

@ -260,7 +260,7 @@ H{ } clone update-map set
{ "<tuple>" "tuples.private" }
{ "tuple>array" "tuples" }
{ "profiling" "tools.profiler.private" }
{ "become" "tuples.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
@ -271,6 +271,7 @@ H{ } clone update-map set
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "strip-compiled-quotations" "quotations" }
}
dup length [ >r first2 r> make-primitive ] 2each

44
core/compiler/test/alien.factor
View File

@ -234,6 +234,50 @@ FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
3 ffi_test_35
] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;

27
core/compiler/test/templates-early.factor
View File

@ -187,3 +187,30 @@ SYMBOL: template-chosen
! This should not fail
[ ] [ [ end-basic-block ] { } make drop ] unit-test
] with-scope
! Regression
SYMBOL: templates-chosen
V{ } clone templates-chosen set
: template-choice-1 ;
\ template-choice-1
[ "template-choice-1" templates-chosen get push ]
H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" } }
} define-intrinsic
: template-choice-2 ;
\ template-choice-2
[ "template-choice-2" templates-chosen get push drop ]
{ { f "x" } { f "y" } } define-if-intrinsic
[ ] [
[ 2 template-choice-1 template-choice-2 ] compile-quot drop
] unit-test
[ V{ "template-choice-1" "template-choice-2" } ]
[ templates-chosen get ] unit-test

2
core/continuations/continuations.factor
View File

@ -89,7 +89,7 @@ C: <continuation> continuation
set-catchstack
set-namestack
set-retainstack
>r set-datastack drop 4 getenv f r>
>r set-datastack drop 4 getenv f 4 setenv f r>
set-callstack ;
PRIVATE>

31
core/cpu/x86/64/64.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
alien ;
alien alien.compiler alien.structs slots splitting math.functions ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
@ -175,3 +175,32 @@ USE: cpu.x86.intrinsics
\ set-alien-signed-4 small-reg-32 define-setter
T{ x86-backend f 8 } compiler-backend set-global
! The ABI for passing structs by value is pretty messed up
"void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
dup slot-spec-type swap slot-spec-offset 2array
] map ;
: split-struct ( pairs -- seq )
[
[ first2 8 mod zero? [ t , ] when , ] each
] { } make { t } split [ empty? not ] subset ;
: flatten-large-struct ( type -- )
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
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
T{ int-regs } swap member?
"void*" "double" ? c-type ,
] each
] if ;

2
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -586,7 +586,7 @@ IN: cpu.x86.intrinsics
"value" operand [ swap MOV ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" c-ptr }
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }

39
core/definitions/definitions-tests.factor Normal file
View File

@ -0,0 +1,39 @@
IN: temporary
USING: tools.test generic kernel definitions sequences ;
TUPLE: combination-1 ;
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
SYMBOL: generic-1
generic-1 T{ combination-1 } define-generic
[ ] <method> object \ generic-1 define-method
[ ] [ { combination-1 { object generic-1 } } forget-all ] unit-test
GENERIC: some-generic
USE: arrays
M: array some-generic ;
USE: bit-arrays
M: bit-array some-generic ;
USE: byte-arrays
M: byte-array some-generic ;
TUPLE: some-class ;
M: some-class some-generic ;
TUPLE: another-class some-generic ;
[ ] [
{ some-generic some-class { another-class some-generic } }
forget-all
] unit-test

2
core/definitions/definitions.factor
View File

@ -13,6 +13,8 @@ GENERIC: forget ( defspec -- )
M: object forget drop ;
: forget-all ( definitions -- ) [ forget ] each ;
GENERIC: synopsis* ( defspec -- )
GENERIC: definer ( defspec -- start end )

56
core/generator/registers/registers.factor
View File

@ -458,8 +458,23 @@ M: loc lazy-store
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: reset-phantom ( phantom -- )
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
over delete-all
swap push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs [ delete-all ] each-phantom ;
finalize-locs finalize-vregs reset-phantoms ;
: %gc ( -- )
0 frame-required
@ -468,8 +483,8 @@ M: loc lazy-store
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
T{ float-regs f 8 } free-vregs length <
>r T{ int-regs } free-vregs length < r> and ;
T{ float-regs f 8 } free-vregs length <=
>r T{ int-regs } free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
[ length f pad-left ] keep
@ -585,24 +600,18 @@ M: loc lazy-store
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-specs-match? ( -- ? )
phantom-d get +input+ get
[ spec-matches? ] phantom&spec-agree? ;
: template-matches? ( spec -- ? )
clone [
template-specs-match?
[ guess-template-vregs free-vregs? ] [ f ] if
] bind ;
: (find-template) ( templates -- pair/f )
[ second template-matches? ] find nip ;
phantom-d get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
guess-template-vregs free-vregs? [
finalize-contents compute-free-vregs
] unless ;
: clear-phantoms ( -- )
[ delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
@ -614,15 +623,11 @@ PRIVATE>
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents finalize-heights
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
: do-template ( pair -- )
#! Use with return value from find-template
first2
clone [ template-inputs call template-outputs ] bind
compute-free-vregs ; inline
: with-template ( quot hash -- )
clone [
ensure-template-vregs
@ -630,6 +635,10 @@ PRIVATE>
] bind
compute-free-vregs ; inline
: do-template ( pair -- )
#! Use with return value from find-template
first2 with-template ;
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
@ -651,10 +660,7 @@ PRIVATE>
: find-template ( templates -- pair/f )
#! Pair has shape { quot hash }
compute-free-vregs
dup (find-template) [ ] [
finalize-contents (find-template)
] ?if ;
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class class-tag ;

11
core/generic/generic.factor
View File

@ -14,6 +14,15 @@ M: generic definition drop f ;
GENERIC: perform-combination ( word combination -- quot )
M: object perform-combination
#! We delay the invalid method combination error for a
#! reason. If we call forget-vocab on a vocabulary which
#! defines a method combination, a generic using this
#! method combination, and a method on the generic, and the
#! method combination is forgotten first, then forgetting
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry ;
: make-generic ( word -- )
dup
dup "combination" word-prop perform-combination
@ -94,7 +103,7 @@ M: method-spec forget first2 [ delete-at ] with-methods ;
dup associate implementors* ;
: forget-methods ( class -- )
[ implementors ] keep [ swap 2array forget ] curry each ;
[ implementors ] keep [ swap 2array ] curry map forget-all ;
M: class forget ( class -- )
dup forget-methods

30
core/memory/memory.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: memory
USING: arrays kernel sequences vectors system ;
USING: arrays kernel sequences vectors system hashtables
kernel.private sbufs growable assocs namespaces quotations
math strings combinators ;
: (each-object) ( quot -- )
next-object dup
@ -14,3 +16,29 @@ USING: arrays kernel sequences vectors system ;
pusher >r each-object r> >array ; inline
: save ( -- ) image save-image ;
<PRIVATE
: intern-objects ( predicate -- )
instances
dup H{ } clone [ [ ] cache ] curry map
become ; inline
: prepare-compress-image ( -- seq )
[ sbuf? ] instances [ underlying ] map ;
PRIVATE>
: compress-image ( -- )
prepare-compress-image "bad-strings" [
[
{
{ [ dup quotation? ] [ t ] }
{ [ dup wrapper? ] [ t ] }
{ [ dup fixnum? ] [ f ] }
{ [ dup number? ] [ t ] }
{ [ dup string? ] [ dup "bad-strings" get memq? not ] }
{ [ t ] [ f ] }
} cond nip
] intern-objects
] with-variable ;

2
core/parser/parser.factor
View File

@ -416,7 +416,7 @@ SYMBOL: parse-hook
] keep ;
: forget-smudged ( -- )
smudged-usage [ forget ] each
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
: record-definitions ( file -- )

4
core/prettyprint/prettyprint-tests.factor
View File

@ -299,3 +299,7 @@ unit-test
[ 2 break 2 \ + (step-into) . ] (remove-breakpoints)
] unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test

7
core/prettyprint/prettyprint.factor
View File

@ -99,7 +99,12 @@ SYMBOL: ->
building get dup empty? [
drop \ (step-into) ,
] [
pop dup wrapper? [ wrapped ] when ,
pop dup wrapper? [
wrapped dup \ break eq?
[ drop ] [ , ] if
] [
,
] if
] if ;
: (remove-breakpoints) ( quot -- newquot )

2
core/source-files/source-files.factor
View File

@ -71,7 +71,7 @@ M: pathname where pathname-string 1 2array ;
: forget-source ( path -- )
dup source-file
dup unxref-source
source-file-definitions [ drop forget ] assoc-each
source-file-definitions keys forget-all
source-files get delete-at ;
M: pathname forget pathname-string forget-source ;

2
core/vocabs/vocabs.factor
View File

@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook
[ ] subset ;
: forget-vocab ( vocab -- )
dup vocab-words [ nip forget ] assoc-each
dup vocab-words values forget-all
vocab-name dictionary get delete-at ;
: child-vocab? ( prefix name -- ? )

9
core/words/words.factor
View File

@ -6,14 +6,14 @@ slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting math.parser words.private
vocabs ;
GENERIC: execute ( word -- )
M: word execute (execute) ;
: word ( -- word ) \ word get-global ;
: set-word ( word -- ) \ word set-global ;
GENERIC: execute ( word -- )
M: word execute (execute) ;
! Used by the compiler
SYMBOL: changed-words
@ -201,7 +201,6 @@ M: word (forget-word)
reveal ;
: forget-word ( word -- )
dup f "methods" set-word-prop
dup delete-xref
dup unchanged-word
(forget-word) ;

16
extra/automata/ui/deploy.factor Normal file
View File

@ -0,0 +1,16 @@
USING: tools.deploy.config ;
V{
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ "bundle-name" "Cellular Automata.app" }
}

13
extra/boids/ui/deploy.factor Normal file
View File

@ -0,0 +1,13 @@
USING: tools.deploy.config ;
V{
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? t }
{ "bundle-name" "Boids.app" }
}

5
extra/bunny/bunny.factor
View File

@ -57,10 +57,7 @@ IN: bunny
] unless ;
: draw-triangle ( ns vs triple -- )
[
dup roll nth first3 glNormal3d
swap nth first3 glVertex3d
] each-with2 ;
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
: draw-bunny ( ns vs is -- )
GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;

6
extra/cabal/cabal.factor
View File

@ -69,13 +69,15 @@ cond ;
! : handle-client ( client -- ) <user> dup users> push
! dup [ >user [ handle-user-loop ] with-stream* ] with-scope ;
: handle-client ( client -- ) <user> dup users> push
: handle-client ( client -- )
<user> dup users> push
dup [ >user [ handle-user-loop ] with-stream ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: accept-client-loop ( server -- )
dup >r accept [ handle-client ] in-thread r> accept-client-loop ;
[ accept [ handle-client ] curry in-thread ] keep
accept-client-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

23
extra/contributors/contributors.factor
View File

@ -1,29 +1,24 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: memory io io.files io.styles io.launcher
sequences prettyprint kernel arrays xml xml.utilities system
hashtables sorting math.parser assocs ;
USING: io.files io.launcher io.styles io hashtables kernel
sequences combinators.lib assocs system sorting math.parser ;
IN: contributors
: changelog ( -- xml )
: changelog ( -- authors )
image parent-dir cd
"darcs changes --xml-output" <process-stream> read-xml ;
: authors ( xml -- seq )
children-tags [ "author" swap at ] map ;
: patch-count ( authors author -- n )
[ = ] curry subset length ;
"git-log --pretty=format:%an" <process-stream> lines ;
: patch-counts ( authors -- assoc )
dup prune [ [ patch-count ] keep 2array ] curry* map ;
dup prune
[ dup rot [ = ] curry* count ] curry*
{ } map>assoc ;
: contributors ( -- )
changelog authors patch-counts sort-keys <reversed>
changelog patch-counts sort-values <reversed>
standard-table-style [
[
[
first2
first2 swap
[ write ] with-cell
[ number>string write ] with-cell
] with-row

5
extra/golden-section/deploy.factor
View File

@ -1,12 +1,17 @@
USING: tools.deploy.config ;
V{
{ strip-io? t }
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ "bundle-name" "Golden Section.app" }
}

6
extra/hello-ui/deploy.factor
View File

@ -1,12 +1,16 @@
USING: tools.deploy.config ;
V{
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-word-names? f }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? t }
{ "stop-after-last-window?" t }
{ "bundle-name" "Hello World.app" }
}

4
extra/hello-world/deploy.factor
View File

@ -1,11 +1,15 @@
USING: tools.deploy.config ;
V{
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? f }
{ deploy-compiled? f }
{ deploy-io? f }
{ deploy-ui? f }
{ "stop-after-last-window?" t }
}

2
extra/jamshred/gl/gl.factor
View File

@ -14,7 +14,7 @@ IN: jamshred.gl
: draw-segment-vertex ( segment theta -- )
over segment-color gl-color segment-vertex-and-normal
first3 glNormal3d first3 glVertex3d ;
gl-normal gl-vertex ;
: draw-vertex-pair ( theta next-segment segment -- )
rot tuck draw-segment-vertex draw-segment-vertex ;

13
extra/lsys/tortoise/graphics/graphics.factor
View File

@ -1,6 +1,7 @@
USING: kernel math vectors sequences opengl.gl math.vectors math.matrices
vars opengl.lib self pos ori turtle lsys.tortoise lsys.strings ;
USING: kernel math vectors sequences opengl.gl math.vectors
math.matrices vars opengl self pos ori turtle lsys.tortoise
lsys.strings ;
IN: lsys.tortoise.graphics
@ -12,7 +13,7 @@ IN: lsys.tortoise.graphics
: (polygon) ( vertices -- )
GL_POLYGON glBegin
dup polygon-normal gl-normal-3f [ gl-vertex-3f ] each
dup polygon-normal gl-normal [ gl-vertex ] each
glEnd ;
: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
@ -31,7 +32,7 @@ VAR: vertices
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-vertex ( -- ) pos> gl-vertex-3f ;
: record-vertex ( -- ) pos> gl-vertex ;
: draw-forward ( length -- )
GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
@ -78,10 +79,10 @@ VAR: color-table
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: material-color ( color -- )
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ;
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
: set-color ( i -- )
dup >color color-table> nth dup gl-color-4f material-color ;
dup >color color-table> nth dup gl-color material-color ;
: inc-color ( -- ) color> 1+ set-color ;

13
extra/lsys/ui/deploy.factor Normal file
View File

@ -0,0 +1,13 @@
USING: tools.deploy ;
V{
{ strip-word-props? t }
{ strip-word-names? t }
{ strip-dictionary? t }
{ strip-debugger? t }
{ strip-c-types? t }
{ deploy-math? t }
{ deploy-compiled? t }
{ deploy-io? f }
{ deploy-ui? t }
{ "bundle-name" "Lindenmayer Systems.app" }
}

11
extra/lsys/ui/ui.factor
View File

@ -1,5 +1,6 @@
USING: kernel namespaces threads math math.vectors quotations sequences
opengl
opengl.gl
colors
ui
@ -11,7 +12,7 @@ USING: kernel namespaces threads math math.vectors quotations sequences
ui.gadgets.lib
ui.gadgets.slate
ui.gadgets.theme
vars rewrite-closures opengl.lib
vars rewrite-closures
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics lsys.strings
;
@ -34,7 +35,7 @@ VAR: model
: display ( -- )
black gl-clear-color
black gl-clear
GL_FLAT glShadeModel
@ -48,13 +49,11 @@ glLoadIdentity
camera> do-look-at
GL_COLOR_BUFFER_BIT glClear
GL_FRONT_AND_BACK GL_LINE glPolygonMode
white gl-color-4f
white gl-color
GL_LINES glBegin { 0 0 0 } gl-vertex-3f { 0 0 1 } gl-vertex-3f glEnd
GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
color> set-color

1
extra/opengl/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Eduardo Cavazos

4
extra/opengl/camera/camera.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces math.vectors opengl.lib pos ori turtle self ;
USING: kernel namespaces math.vectors opengl pos ori turtle self ;
IN: opengl.camera
@ -13,4 +13,4 @@ IN: opengl.camera
[ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ;
: do-look-at ( camera -- )
[ >self camera-eye camera-focus camera-up glu-look-at ] with-scope ;
[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;

19
extra/opengl/lib/lib.factor
View File

@ -1,19 +0,0 @@
USING: kernel alien.c-types sequences opengl.gl opengl.glu ;
IN: opengl.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-color-4f ( 4seq -- ) first4 glColor4f ;
: gl-clear-color ( 4seq -- ) first4 glClearColor ;
: gl-vertex-3f ( array -- ) first3 glVertex3f ;
: gl-normal-3f ( array -- ) first3 glNormal3f ;
: gl-material-fv ( face pname params -- ) >c-float-array glMaterialfv ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: glu-look-at ( eye focus up -- ) >r >r first3 r> first3 r> first3 gluLookAt ;

25
extra/opengl/opengl.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! Copyright (C) 2005, 2007 Slava Pestov.
! Portions copyright (C) 2007 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types io kernel math namespaces
sequences math.vectors opengl.gl opengl.glu ;
sequences math.vectors opengl.gl opengl.glu combinators ;
IN: opengl
: coordinates [ first2 ] 2apply ;
@ -10,8 +11,11 @@ IN: opengl
: gl-color ( color -- ) first4 glColor4d ; inline
: gl-clear-color ( color -- )
first4 glClearColor ;
: gl-clear ( color -- )
first4 glClearColor GL_COLOR_BUFFER_BIT glClear ;
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: gl-error ( -- )
glGetError dup zero? [
@ -28,7 +32,17 @@ IN: opengl
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
: gl-vertex ( point -- ) first2 glVertex2d ; inline
: gl-vertex ( point -- )
dup length {
{ 2 [ first2 glVertex2d ] }
{ 3 [ first3 glVertex3d ] }
{ 4 [ first4 glVertex4d ] }
} case ;
: gl-normal ( normal -- ) first3 glNormal3d ;
: gl-material ( face pname params -- )
>c-float-array glMaterialfv ;
: gl-line ( a b -- )
GL_LINES [ gl-vertex gl-vertex ] do-state ;
@ -67,6 +81,9 @@ IN: opengl
: do-attribs ( bits quot -- )
swap glPushAttrib call glPopAttrib ; inline
: gl-look-at ( eye focus up -- )
>r >r first3 r> first3 r> first3 gluLookAt ;
TUPLE: sprite loc dim dim2 dlist texture ;
: <sprite> ( loc dim dim2 -- sprite )

2
extra/tools/deploy/config/config.factor
View File

@ -4,6 +4,7 @@ USING: vocabs.loader io.files io kernel sequences assocs
splitting parser prettyprint ;
IN: tools.deploy.config
SYMBOL: strip-io?
SYMBOL: strip-globals?
SYMBOL: strip-word-props?
SYMBOL: strip-word-names?
@ -22,6 +23,7 @@ SYMBOL: deploy-image
: default-config ( -- assoc )
V{
{ strip-io? f }
{ strip-prettyprint? t }
{ strip-globals? t }
{ strip-word-props? t }

1
extra/tools/deploy/deploy.factor
View File

@ -57,4 +57,5 @@ PRIVATE>
deploy-command-line stage2 ;
: deploy ( vocab -- )
"" resource-path cd
vm over ".image" append rot dup deploy-config deploy* ;

15
extra/tools/deploy/shaker/shaker.factor
View File

@ -15,19 +15,20 @@ IN: tools.deploy.shaker
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"command-line" init-hooks get delete-at ;
"command-line" init-hooks get delete-at
strip-io? get [ "io.backend" init-hooks get delete-at ] when ;
: strip-debugger ( -- )
strip-debugger? get [
"Stripping debugger" show
"resource:extra/tools/deploy/strip-debugger.factor"
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
run-file
] when ;
: strip-cocoa ( -- )
"cocoa" vocab [
"Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/strip-cocoa.factor"
"resource:extra/tools/deploy/shaker/strip-cocoa.factor"
run-file
] when ;
@ -90,6 +91,8 @@ USING: bit-arrays byte-arrays io.streams.nested ;
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Stripping compiled quotations" show
strip-compiled-quotations
"Saving final image" show
[ save-image-and-exit ] call-clear ;
@ -100,14 +103,14 @@ SYMBOL: deploy-vocab
\ boot ,
init-hooks get values concat %
,
"io.backend" init-hooks get at [ \ flush , ] when
strip-io? get [ \ flush , ] unless
] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ;
: retained-globals ( -- seq )
[
builtins ,
io-backend ,
strip-io? get [ io-backend , ] unless
strip-dictionary? get [
{
@ -178,6 +181,8 @@ SYMBOL: deploy-vocab
deploy-vocab get require
r> [ call ] when*
strip
"Compressing image" show
compress-image
finish-deploy
] [
print-error flush 1 exit

0
extra/tools/deploy/strip-cocoa.factor → extra/tools/deploy/shaker/strip-cocoa.factor
View File

2
extra/tools/deploy/strip-debugger.factor → extra/tools/deploy/shaker/strip-debugger.factor
View File

@ -1,4 +1,6 @@
USING: kernel ;
IN: debugger
: print-error die ;
: error. die ;

4
extra/tools/interpreter/interpreter.factor
View File

@ -65,12 +65,14 @@ M: word (step-into) (step-into-execute) ;
{
>n ndrop >c c>
continue continue-with
(continue-with) stop break
(continue-with) stop
} [
dup [ execute break ] curry
"step-into" set-word-prop
] each
\ break [ break ] "step-into" set-word-prop
! Stepping
: change-innermost-frame ( quot interpreter -- )
interpreter-continuation [

6
extra/ui/tools/walker/walker-tests.factor
View File

@ -65,4 +65,10 @@ IN: temporary
[ ] [ yield ] unit-test
[ t ] [ walker get-tool walker-active? ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
] with-scope

6
extra/ui/tools/walker/walker.factor
View File

@ -67,7 +67,11 @@ M: walker call-tool* ( continuation walker -- )
: com-continue ( walker -- )
#! Reset walker first, in case step-all ends up calling
#! the walker again.
dup walker-interpreter swap reset-walker step-all ;
dup walker-active? [
dup walker-interpreter swap reset-walker step-all
] [
drop
] if ;
: walker-help "ui-walker" help-window ;

1
vm/data_gc.c
View File

@ -446,6 +446,7 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
INLINE void forward_object(CELL pointer, CELL newpointer)
{
if(pointer != newpointer)
put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
}

47
vm/debug.c
View File

@ -1,14 +1,23 @@
#include "master.h"
void print_chars(F_STRING* str)
{
CELL i;
for(i = 0; i < string_capacity(str); i++)
putchar(cget(SREF(str,i)));
}
void print_word(F_WORD* word, CELL nesting)
{
if(type_of(word->name) == STRING_TYPE)
if(type_of(word->vocabulary) == STRING_TYPE)
{
F_STRING *string = untag_string(word->name);
CELL i;
for(i = 0; i < string_capacity(string); i++)
putchar(cget(SREF(string,i)));
print_chars(untag_string(word->vocabulary));
printf(":");
}
if(type_of(word->name) == STRING_TYPE)
print_chars(untag_string(word->name));
else
{
printf("#<not a string: ");
@ -20,9 +29,7 @@ void print_word(F_WORD* word, CELL nesting)
void print_string(F_STRING* str)
{
putchar('"');
CELL i;
for(i = 0; i < string_capacity(str); i++)
putchar(cget(SREF(str,i)));
print_chars(str);
putchar('"');
}
@ -181,6 +188,24 @@ void dump_generations(void)
(CELL)(data_heap->cards_end - data_heap->cards));
}
void dump_objects(F_FIXNUM type)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type == -1 || type_of(obj) == type)
{
print_nested_obj(obj,3);
printf("\n");
}
}
/* end scan */
gc_off = false;
}
void factorbug(void)
{
reset_stdio();
@ -200,6 +225,8 @@ void factorbug(void)
printf("g -- dump generations\n");
printf("card <addr> -- print card containing address\n");
printf("addr <card> -- print address containing card\n");
printf("data -- data heap dump\n");
printf("words -- words dump\n");
printf("code -- code heap dump\n");
for(;;)
@ -268,6 +295,10 @@ void factorbug(void)
exit(1);
else if(strcmp(cmd,"im") == 0)
save_image(STR_FORMAT("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
else

7
vm/factor.c
View File

@ -19,6 +19,7 @@ void default_parameters(F_PARAMETERS *p)
p->young_size = 2 * CELLS;
p->aging_size = 4 * CELLS;
p->secure_gc = false;
p->fep = false;
}
/* Get things started */
@ -101,6 +102,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
else if(STRCMP(argv[i],STR_FORMAT("-fep")) == 0)
p.fep = true;
else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
p.image = argv[i] + 3;
}
@ -127,6 +130,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
userenv[EMBEDDED_ENV] = (embedded ? T : F);
nest_stacks();
if(p.fep)
factorbug();
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();

20
vm/ffi_test.c
View File

@ -225,3 +225,23 @@ struct test_struct_7 ffi_test_30(void)
}
void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) { }
double ffi_test_32(struct test_struct_8 x, int y)
{
return (x.x + x.y) * y;
}
double ffi_test_33(struct test_struct_9 x, int y)
{
return (x.x + x.y) * y;
}
double ffi_test_34(struct test_struct_10 x, int y)
{
return (x.x + x.y) * y;
}
double ffi_test_35(struct test_struct_11 x, int y)
{
return (x.x + x.y) * y;
}

8
vm/ffi_test.h
View File

@ -49,3 +49,11 @@ DLLEXPORT struct test_struct_6 ffi_test_29(void);
struct test_struct_7 { char x, y, z, a, b, c, d; };
DLLEXPORT struct test_struct_7 ffi_test_30(void);
DLLEXPORT void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
struct test_struct_8 { double x; double y; };
DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y);
struct test_struct_9 { float x; float y; };
DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y);
struct test_struct_10 { float x; int y; };
DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y);
struct test_struct_11 { int x; int y; };
DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);

1
vm/image.h
View File

@ -31,6 +31,7 @@ typedef struct {
CELL gen_count, young_size, aging_size;
CELL code_size;
bool secure_gc;
bool fep;
} F_PARAMETERS;
void load_image(F_PARAMETERS *p);

1
vm/primitives.c
View File

@ -194,4 +194,5 @@ void *primitives[] = {
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_strip_compiled_quotations,
};

19
vm/quotations.c
View File

@ -231,3 +231,22 @@ DEFINE_PRIMITIVE(quotation_xt)
F_QUOTATION *quot = untag_quotation(dpeek());
drepl(allot_cell((CELL)quot->xt));
}
DEFINE_PRIMITIVE(strip_compiled_quotations)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
quot->compiled = F;
quot->xt = lazy_jit_compile;
}
}
/* end scan */
gc_off = false;
}

1
vm/quotations.h
View File

@ -6,3 +6,4 @@ DECLARE_PRIMITIVE(curry);
DECLARE_PRIMITIVE(array_to_quotation);
DECLARE_PRIMITIVE(quotation_xt);
DECLARE_PRIMITIVE(uncurry);
DECLARE_PRIMITIVE(strip_compiled_quotations);