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

core/alien/compiler/compiler.factor

@@ -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
+    over >r c-type-stack-align align dup r> - ;
-    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if
-    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 )
+GENERIC: flatten-value-type ( type -- )
-    [ parameter-align (flatten-int-type) ] keep
-    stack-size cell align dup (flatten-int-type) + ;
 
-: flatten-value-type ( n type -- n )
+M: object flatten-value-type , ;
-    dup c-type c-type-reg-class T{ int-regs } =
+
-    [ flatten-int-type ] [ , ] if ;
+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
+    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
-    drop ; inline
+    inline
 
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline

core/bootstrap/primitives.factor

@@ -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
 

core/compiler/test/alien.factor

@@ -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 ;

core/compiler/test/templates-early.factor

@@ -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

core/continuations/continuations.factor

@@ -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>

core/cpu/x86/64/64.factor

@@ -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 ;

core/cpu/x86/intrinsics/intrinsics.factor

@@ -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 }
     } }

core/definitions/definitions-tests.factor

@@ -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

core/definitions/definitions.factor

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

core/generator/registers/registers.factor

@@ -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 <
+    T{ float-regs f 8 } free-vregs length <=
-    >r T{ int-regs } free-vregs length < r> and ;
+    >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 [
+    phantom-d get +input+ rot at
-        template-specs-match?
+    [ spec-matches? ] phantom&spec-agree? ;
-        [ guess-template-vregs free-vregs? ] [ f ] if
-    ] bind ;
-
-: (find-template) ( templates -- pair/f )
-    [ second template-matches? ] find nip ;
 
 : 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
+    [ second template-matches? ] find nip ;
-    dup (find-template) [ ] [
-        finalize-contents (find-template)
-    ] ?if ;
 
 : operand-tag ( operand -- tag/f )
     operand-class class-tag ;

core/generic/generic.factor

@@ -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

core/memory/memory.factor

@@ -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 ;

core/parser/parser.factor

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

core/prettyprint/prettyprint-tests.factor

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

core/prettyprint/prettyprint.factor

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

core/source-files/source-files.factor

@@ -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 ;

core/vocabs/vocabs.factor

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

core/words/words.factor

@@ -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) ;

extra/automata/ui/deploy.factor

@@ -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" }
+}

extra/boids/ui/deploy.factor

@@ -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" }
+}

extra/bunny/bunny.factor

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

extra/cabal/cabal.factor

@@ -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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/contributors/contributors.factor

@@ -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
+USING: io.files io.launcher io.styles io hashtables kernel
-sequences prettyprint kernel arrays xml xml.utilities system
+sequences combinators.lib assocs system sorting math.parser ;
-hashtables sorting math.parser assocs ;
 IN: contributors
 
-: changelog ( -- xml )
+: changelog ( -- authors )
     image parent-dir cd
-    "darcs changes --xml-output" <process-stream> read-xml ;
+    "git-log --pretty=format:%an" <process-stream> lines ;
-
-: authors ( xml -- seq )
-    children-tags [ "author" swap at ] map ;
-
-: patch-count ( authors author -- n )
-    [ = ] curry subset length ;
 
 : 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

extra/golden-section/deploy.factor

@@ -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" }
 }

extra/hello-ui/deploy.factor

@@ -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" }
 }

extra/hello-world/deploy.factor

@@ -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 }
 }

extra/jamshred/gl/gl.factor

@@ -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 ;

extra/lsys/tortoise/graphics/graphics.factor

@@ -1,6 +1,7 @@
 
-USING: kernel math vectors sequences opengl.gl math.vectors math.matrices
+USING: kernel math vectors sequences opengl.gl math.vectors
-       vars opengl.lib self pos ori turtle lsys.tortoise lsys.strings ;
+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 ;
 

extra/lsys/ui/deploy.factor

@@ -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" }
+}

extra/lsys/ui/ui.factor

@@ -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
 

extra/opengl/authors.txt

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

extra/opengl/camera/camera.factor

@@ -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 ;

extra/opengl/lib/lib.factor

@@ -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 ;

extra/opengl/opengl.factor

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

extra/tools/deploy/config/config.factor

@@ -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 }

extra/tools/deploy/deploy.factor

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

extra/tools/deploy/shaker/shaker.factor

@@ -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

extra/tools/deploy/shaker/strip-debugger.factor

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

extra/tools/interpreter/interpreter.factor

@@ -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 [

extra/ui/tools/walker/walker-tests.factor

@@ -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

extra/ui/tools/walker/walker.factor

@@ -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 ;
 

vm/data_gc.c

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

vm/debug.c

@@ -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);
+		print_chars(untag_string(word->vocabulary));
-		CELL i;
+		printf(":");
-		for(i = 0; i < string_capacity(string); i++)
-			putchar(cget(SREF(string,i)));
 	}
+	
+	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;
+	print_chars(str);
-	for(i = 0; i < string_capacity(str); i++)
-		putchar(cget(SREF(str,i)));
 	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,8 +225,10 @@ 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(;;)
 	{
 		char cmd[1024];
@@ -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

vm/factor.c

@@ -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();
 

vm/ffi_test.c

@@ -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;
+}

vm/ffi_test.h

@@ -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);

vm/image.h

@@ -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);

vm/primitives.c

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

vm/quotations.c

@@ -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;
+}

vm/quotations.h

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