Merge remote-tracking branch 'origin/master' into modern-harvey3

LICENSE.txt

@@ -1,4 +1,4 @@
-Copyright (c) 2019, Slava Pestov, et al.
+Copyright (c) 2020, Slava Pestov, et al.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

basis/compiler/cfg/builder/alien/alien.factor

@@ -15,6 +15,8 @@ IN: compiler.cfg.builder.alien
         0 stack-params set
         V{ } clone reg-values set
         V{ } clone stack-values set
+        0 int-reg-reps set
+        0 float-reg-reps set
         @
         reg-values get
         stack-values get

basis/compiler/cfg/builder/alien/boxing/boxing.factor

@@ -10,19 +10,30 @@ IN: compiler.cfg.builder.alien.boxing
 
 SYMBOL: struct-return-area
 
+SYMBOLS: int-reg-reps float-reg-reps ;
+
+: reg-reps ( reps -- int-reps float-reps )
+    [ second ] reject [ [ first int-rep? ] count ] [ length over - ] bi ;
+
+: record-reg-reps ( reps -- reps )            
+    dup reg-reps [ int-reg-reps +@ ] [ float-reg-reps +@ ] bi* ;
+
+: unrecord-reg-reps ( reps -- reps )
+    dup reg-reps [ neg int-reg-reps +@ ] [ neg float-reg-reps +@ ] bi* ;
+
 GENERIC: flatten-c-type ( c-type -- pairs )
 
 M: c-type flatten-c-type
-    rep>> f f 3array 1array ;
+    rep>> f f 3array 1array record-reg-reps ;
 
 M: long-long-type flatten-c-type
-    drop 2 [ int-rep long-long-on-stack? f 3array ] replicate ;
+    drop 2 [ int-rep long-long-on-stack? f 3array ] replicate record-reg-reps ;
 
 HOOK: flatten-struct-type cpu ( type -- pairs )
 HOOK: flatten-struct-type-return cpu ( type -- pairs )
 
 M: object flatten-struct-type
-    heap-size cell align cell /i { int-rep f f } <array> ;
+    heap-size cell align cell /i { int-rep f f } <array> record-reg-reps ;
 
 M: struct-c-type flatten-c-type
     flatten-struct-type ;
@@ -70,12 +81,12 @@ M: c-type unbox
             [ swap ^^unbox ]
         } case 1array
     ]
-    [ drop f f 3array 1array ] 2bi ;
+    [ drop f f 3array 1array ] 2bi record-reg-reps ;
 
 M: long-long-type unbox
     [ next-vreg next-vreg 2dup ] 2dip unboxer>> unbox-long-long##, 2array
     int-rep long-long-on-stack? long-long-odd-register? 3array
-    int-rep long-long-on-stack? f 3array 2array ;
+    int-rep long-long-on-stack? f 3array 2array record-reg-reps ;
 
 M: struct-c-type unbox ( src c-type -- vregs reps )
     [ ^^unbox-any-c-ptr ] dip explode-struct ;

basis/compiler/tests/alien.factor

@@ -2,7 +2,7 @@ USING: accessors alien alien.c-types alien.complex alien.data alien.libraries
 alien.syntax arrays byte-arrays classes classes.struct combinators
 combinators.extras compiler compiler.test concurrency.promises continuations
 destructors effects generalizations io io.backend io.pathnames
-io.streams.string kernel kernel.private libc layouts math math.bitwise
+io.streams.string kernel kernel.private libc layouts locals math math.bitwise
 math.private memory namespaces namespaces.private random parser quotations
 sequences slots.private specialized-arrays stack-checker stack-checker.errors
 system threads tools.test words ;
@@ -962,3 +962,117 @@ FUNCTION: void* bug1021_test_3 ( c-string a )
 { } [
     10000 [ 0 doit 33 assert= ] times
 ] unit-test
+
+! Tests for System V AMD64 ABI 
+STRUCT: test_struct_66 { mem1 ulong } { mem2 ulong } ;
+STRUCT: test_struct_68 { mem1 ulong } { mem2 ulong } { mem3 ulong } ;
+STRUCT: test_struct_69 { mem1 float } { mem2 ulong } { mem3 ulong } ;
+FUNCTION: ulong ffi_test_66 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e )
+FUNCTION: ulong ffi_test_67 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e ulong _f )
+FUNCTION: ulong ffi_test_68 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_68 e test_struct_66 _f )
+FUNCTION: ulong ffi_test_69 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_69 e test_struct_66 _f )
+FUNCTION: ulong ffi_test_70 ( test_struct_68 a test_struct_68 b, test_struct_66 c )  
+
+{ 28 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } ffi_test_66 ] unit-test
+
+: callback-14 ( -- callback )
+    ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl
+    [| a b c d e |
+        a b + c +
+        d [ mem1>> + ] [ mem2>> + ] bi
+        e [ mem1>> + ] [ mem2>> + ] bi
+    ] alien-callback ;
+
+: callback-14-test ( a b c d e callback -- result )
+    ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl alien-indirect ;
+
+{ 28 } [
+    1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } callback-14 [
+        callback-14-test
+    ] with-callback
+] unit-test
+
+{ 44 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 ffi_test_67 ] unit-test
+
+: callback-15 ( -- callback )
+    ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl
+    [| a b c d e _f |
+        a b + c +
+        d [ mem1>> + ] [ mem2>> + ] bi
+        e [ mem1>> + ] [ mem2>> + ] bi
+        _f 2 * + 
+    ] alien-callback ;
+
+: callback-15-test ( a b c d e _f callback -- result )
+    ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl alien-indirect ;
+
+{ 44 } [
+    1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 callback-15 [
+        callback-15-test
+    ] with-callback
+] unit-test
+
+{ 55 } [
+    1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } ffi_test_68
+] unit-test
+
+: callback-16 ( -- callback )
+    ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl
+    [| a b c d e _f |
+        a b + c +
+        d [ mem1>> + ] [ mem2>> + ] bi
+        e [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
+        _f [ mem1>> + ] [ mem2>> + ] bi
+    ] alien-callback ;
+
+: callback-16-test ( a b c d e _f callback -- result )
+    ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl alien-indirect ;
+
+{ 55 } [
+    1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } callback-16 [
+        callback-16-test
+    ] with-callback
+] unit-test
+
+{ 55 } [
+   1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
+] unit-test
+
+: callback-17 ( -- callback )
+    ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl
+    [| a b c d e _f |
+        a b + c +
+        d [ mem1>> + ] [ mem2>> + ] bi
+        e [ mem1>> >integer + ] [ mem2>> + ] [ mem3>> + ] tri
+        _f [ mem1>> + ] [ mem2>> + ] bi
+    ] alien-callback ;
+
+: callback-17-test ( a b c d e _f callback -- result )
+    ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl alien-indirect ;
+
+{ 55 } [
+    1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } callback-17 [
+        callback-17-test
+    ] with-callback
+] unit-test
+
+{ 36 } [
+    S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } ffi_test_70
+] unit-test
+
+: callback-18 ( -- callback )
+    ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl
+    [| a b c |
+        a [ mem1>> ] [ mem2>> + ] [ mem3>> + ] tri     
+        b [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
+        c [ mem1>> + ] [ mem2>> + ] bi
+    ] alien-callback ;
+
+: callback-18-test ( a b c callback -- result )
+    ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl alien-indirect ;
+
+{ 36 } [
+    S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } callback-18 [
+        callback-18-test
+    ] with-callback
+] unit-test

basis/cpu/x86/64/unix/unix.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types arrays assocs
 compiler.cfg.builder.alien.boxing cpu.architecture cpu.x86
-cpu.x86.assembler cpu.x86.assembler.operands kernel layouts make math
+cpu.x86.assembler cpu.x86.assembler.operands kernel layouts locals
-math.order sequences splitting system ;
+make math math.order namespaces sequences splitting system ;
 IN: cpu.x86.64.unix
 
 M: x86.64 param-regs
@@ -24,16 +24,26 @@ M: x86.64 reserved-stack-space 0 ;
         [ 8 mod zero? [ t , ] when , ] assoc-each
     ] { } make { t } split harvest ;
 
-: flatten-small-struct ( c-type -- seq )
+:: flatten-small-struct ( c-type -- seq )
-    struct-types&offset split-struct [
+    c-type struct-types&offset split-struct [
         [ lookup-c-type c-type-rep reg-class-of ] map
         int-regs swap member? int-rep double-rep ?
         f f 3array
-    ] map ;
+    ] map :> reps
+    int-reg-reps get float-reg-reps get and [
+        reps reg-reps :> ( int-mems float-mems )
+        int-reg-reps get int-mems + 6 >
+        float-reg-reps get float-mems + 8 > or [
+            reps [ first t f 3array ] map
+        ] [ reps ] if
+    ] [ reps ] if ;
 
 M: x86.64 flatten-struct-type ( c-type -- seq )
     dup heap-size 16 <=
-    [ flatten-small-struct ] [ call-next-method [ first t f 3array ] map ] if ;
+    [ flatten-small-struct record-reg-reps ] [
+        call-next-method unrecord-reg-reps
+        [ first t f 3array ] map
+    ] if ;
 
 M: x86.64 return-struct-in-registers? ( c-type -- ? )
     heap-size 2 cells <= ;

basis/ui/backend/cocoa/views/views.factor

@@ -23,7 +23,7 @@ SLOT: window
 
 ! Issue #1453
 : button ( event -- n )
-    ! Cocoa send: Factor UI button mapping
+    ! Cocoa -> Factor UI button mapping
     send: buttonNumber {
         { 0 [ 1 ] }
         { 1 [ 3 ] }
@@ -238,23 +238,22 @@ IMPORT: NSAttributedString
     ] [ underlines ] if ;
 
 :: update-marked-text ( gadget str selectedRange replacementRange -- )
-    replacementRange location>>  NSNotFound = not     ! [ 
+    replacementRange location>> NSNotFound = [
-    replacementRange length>> NSNotFound = not and [  ! erase this line
         gadget editor-caret first
         dup gadget editor-line
         [
-            replacementRange length>> ! location>>
+            replacementRange location>>
             >codepoint-index
             2array gadget set-caret
         ] [
-            replacementRange length>> 1 + ! [ location>> ] [ length>> ] bi +
+            replacementRange [ location>> ] [ length>> ] bi +
             >codepoint-index
             2array gadget set-mark
         ] 2bi
         gadget earlier-caret/mark dup
         gadget preedit-start<<
         0 1 2array v+ gadget preedit-end<<
-    ] when
+    ] unless
 
     gadget preedit? [
         gadget remove-preedit-text
@@ -287,7 +286,7 @@ PRIVATE>
         self selector: \setWantsBestResolutionOpenGLSurface:
         send: \respondsToSelector: c-bool> [
 
-            self 1 { void { id SEL char } } ?send: setWantsBestResolutionOpenGLSurface:
+            self 1 { void { id SEL char } } ?send: \setWantsBestResolutionOpenGLSurface:
 
             self { double { id SEL } } ?send: backingScaleFactor
 
@@ -368,35 +367,35 @@ PRIVATE>
             gadget [
                 gadget preedit? not [
                     window event send: action utf8 alien>string validate-action
-                    [ >c-bool ] [ drop self event super: \validateUserInterfaceItem: ] if
+                    [ >c-bool ] [ drop self event super: validateUserInterfaceItem: ] if
                 ] [ 0 ] if
             ] [ 0 ] if
         ] [ 0 ] if
     ] ;
 
-    COCOA-METHOD: id undo: id event [ self event undo-action send-action$ f ] ;
+    COCOA-METHOD: void undo: id event [ self event undo-action send-action$ ] ;
 
-    COCOA-METHOD: id redo: id event [ self event redo-action send-action$ f ] ;
+    COCOA-METHOD: void redo: id event [ self event redo-action send-action$ ] ;
 
-    COCOA-METHOD: id cut: id event [ self event cut-action send-action$ f ] ;
+    COCOA-METHOD: void cut: id event [ self event cut-action send-action$ ] ;
 
-    COCOA-METHOD: id copy: id event [ self event copy-action send-action$ f ] ;
+    COCOA-METHOD: void copy: id event [ self event copy-action send-action$ ] ;
 
-    COCOA-METHOD: id paste: id event [ self event paste-action send-action$ f ] ;
+    COCOA-METHOD: void paste: id event [ self event paste-action send-action$ ] ;
 
-    COCOA-METHOD: id delete: id event [ self event delete-action send-action$ f ] ;
+    COCOA-METHOD: void delete: id event [ self event delete-action send-action$ ] ;
 
-    COCOA-METHOD: id selectAll: id event [ self event select-all-action send-action$ f ] ;
+    COCOA-METHOD: void selectAll: id event [ self event select-all-action send-action$ ] ;
 
-    COCOA-METHOD: id newDocument: id event [ self event new-action send-action$ f ] ;
+    COCOA-METHOD: void newDocument: id event [ self event new-action send-action$ ] ;
 
-    COCOA-METHOD: id openDocument: id event [ self event open-action send-action$ f ] ;
+    COCOA-METHOD: void openDocument: id event [ self event open-action send-action$ ] ;
 
-    COCOA-METHOD: id saveDocument: id event [ self event save-action send-action$ f ] ;
+    COCOA-METHOD: void saveDocument: id event [ self event save-action send-action$ ] ;
 
-    COCOA-METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ] ;
+    COCOA-METHOD: void saveDocumentAs: id event [ self event save-as-action send-action$ ] ;
 
-    COCOA-METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ] ;
+    COCOA-METHOD: void revertDocumentToSaved: id event [ self event revert-action send-action$ ] ;
 
     ! Multi-touch gestures
     COCOA-METHOD: void magnifyWithEvent: id event
@@ -458,149 +457,149 @@ PRIVATE>
         ] [ 0 ] if
     ] ;
 
+    ! Text input
     COCOA-METHOD: void insertText: id text replacementRange: NSRange replacementRange [
-            self window :> window
+        self window :> window
-            window [
+        window [
+            "" clone :> str!
+            text NSString send: class send: isKindOfClass: 0 = not [
+                text CFString>string str!
+            ] [
+                text send: string CFString>string str!
+            ] if
+            window world-focus :> gadget
+            gadget [
+                gadget support-input-methods? [
+                    replacementRange location>> NSNotFound = [
+                        gadget editor-caret first
+                        dup gadget editor-line
+                        [
+                            replacementRange location>> >codepoint-index
+                            2array gadget set-caret
+                        ] [
+                            replacementRange [ location>> ] [ length>> ] bi +
+                            >codepoint-index
+                            2array gadget set-mark
+                        ] 2bi
+                    ] unless
+                    gadget preedit? [
+                        gadget remove-preedit-text
+                        gadget remove-preedit-info
+                        str gadget user-input* drop
+                        f gadget preedit-selection-mode?<<
+                    ] [
+                        str window user-input
+                    ] if
+                ] [
+                    str window user-input
+                ] if
+            ] when
+        ] when
+    ] ;
+
+    COCOA-METHOD: char hasMarkedText [
+        self window :> window
+        window [
+            window world-focus :> gadget
+            gadget [
+                gadget preedit? 1 0 ?
+            ] [ 0 ] if
+        ] [ 0 ] if
+    ] ;
+
+    COCOA-METHOD: NSRange markedRange [
+        self window :> window
+        window [
+            window world-focus :> gadget
+            gadget [
+                gadget preedit? [
+                    gadget preedit-start>> second
+                    gadget preedit-end>> second < [
+                        gadget preedit-start>> first gadget editor-line :> str
+                        gadget preedit-start>> second           ! location
+                        gadget preedit-end>> second
+                        [ str swap >utf16-index ] bi@ over -    ! length
+                    ] [ NSNotFound 0 ] if
+                ] [ NSNotFound 0 ] if
+            ] [ NSNotFound 0 ] if
+        ] [ NSNotFound 0 ] if
+        <NSRange>
+    ] ;
+
+    COCOA-METHOD: NSRange selectedRange [
+        self window :> window
+        window [
+            window world-focus :> gadget
+            gadget [
+                gadget support-input-methods? [
+                    gadget editor-caret first gadget editor-line :> str
+                    gadget preedit? [
+                        str
+                        gadget preedit-selected-start>> second
+                        gadget preedit-start>> second
+                        - >utf16-index                        ! location
+                        gadget preedit-selected-end>> second
+                        gadget preedit-selected-start>> second
+                        [ str swap >utf16-index ] bi@ -       ! length
+                    ] [
+                        str gadget editor-caret second >utf16-index 0
+                    ] if
+                ] [ 0 0 ] if
+            ] [ 0 0 ] if
+        ] [ 0 0 ] if
+        <NSRange>
+    ] ;
+
+    COCOA-METHOD: void setMarkedText: id text selectedRange: NSRange selectedRange
+                                     replacementRange: NSRange replacementRange [
+        self window :> window
+        window [
+            window world-focus :> gadget
+            gadget [
+                { } clone :> underlines!
                 "" clone :> str!
                 text NSString send: class send: isKindOfClass: 0 = not [
                     text CFString>string str!
                 ] [
                     text send: string CFString>string str!
-                ] if
-                window world-focus :> gadget
-                gadget [
                     gadget support-input-methods? [
-                        replacementRange location>> NSNotFound = [
+                        gadget text selectedRange make-preedit-underlines underlines!
-                            gadget editor-caret first
-                            dup gadget editor-line
-                            [
-                                replacementRange location>> >codepoint-index
-                                2array gadget set-caret
-                            ] [
-                                replacementRange [ location>> ] [ length>> ] bi +
-                                >codepoint-index
-                                2array gadget set-mark
-                            ] 2bi
-                        ] unless
-                        gadget preedit? [
-                            gadget [ remove-preedit-text ] [ remove-preedit-info ] bi
-                            str gadget user-input* drop
-                            f gadget preedit-selection-mode?<<
-                        ] [
-                            str window user-input
-                        ] if
-                    ] [
-                        str window user-input
-                    ] if
-                ] when
-            ] when
-        ] ;
-
-    COCOA-METHOD: char hasMarkedText [
-            self window :> window
-            window [
-                window world-focus :> gadget
-                gadget [
-                    gadget preedit? [ 1 ] [ 0 ] if
-                ] [ 0 ] if
-            ] [ 0 ] if
-        ] ;
-
-    COCOA-METHOD: NSRange markedRange [
-            self window :> window
-            window [
-                window world-focus :> gadget
-                gadget [
-                    gadget preedit? [
-                        gadget [ preedit-start>> second ] [ preedit-end>> second ] bi >= [
-                            NSNotFound 0
-                        ] [
-                            gadget preedit-start>> first gadget editor-line :> str
-                            gadget
-                            [ preedit-start>> second ]                 ! location
-                            [ preedit-end>> second ]
-                            bi [ str swap >utf16-index ] bi@ over -    ! length
-                        ] if
-                    ] [  NSNotFound 0 ] if
-                ] [  NSNotFound 0 ] if
-            ] [ NSNotFound 0 ] if
-            <NSRange>
-        ] ;
-
-    COCOA-METHOD: NSRange selectedRange [
-            self window :> window
-            window [
-                window world-focus :> gadget
-                gadget [
-                    gadget support-input-methods? [
-                        gadget editor-caret first gadget editor-line :> str
-                        gadget preedit? [
-                            str
-                            gadget
-                            [ preedit-selected-start>> second ]
-                            [ preedit-start>> second ]
-                            bi - >utf16-index                        ! location
-                            gadget
-                            [ preedit-selected-end>> second ]
-                            [ preedit-selected-start>> second ]
-                            bi [ str swap >utf16-index ] bi@ -       ! length
-                        ] [
-                            str gadget editor-caret second >utf16-index 0
-                        ] if
-                    ] [ 0 0 ] if
-                ] [ 0 0 ] if
-            ] [ 0 0 ] if
-            <NSRange>
-        ] ;
-   
-    COCOA-METHOD: void setMarkedText: id text selectedRange: NSRange selectedRange
-                                     replacementRange: NSRange replacementRange [
-            self window :> window
-            window [
-                window world-focus :> gadget
-                gadget [
-                    { } clone :> underlines!
-                    "" clone :> str!
-                    text NSString send: class send: isKindOfClass: 0 = not [
-                        text CFString>string str!
-                    ] [
-                        text send: string CFString>string str!
-                        gadget support-input-methods? [
-                            gadget text selectedRange make-preedit-underlines underlines!
-                        ] when
-                    ] if
-                    gadget support-input-methods? [
-                        gadget str selectedRange replacementRange update-marked-text
-                        underlines gadget preedit-underlines<<
                     ] when
+                ] if
+                gadget support-input-methods? [
+                    gadget str selectedRange replacementRange update-marked-text
+                    underlines gadget preedit-underlines<<
                 ] when
             ] when
-        ] ;
+        ] when
+    ] ;
 
     COCOA-METHOD: void unmarkText [
-            self window :> window
+        self window :> window
-            window [
+        window [
-                window world-focus :> gadget
+            window world-focus :> gadget
-                gadget [
+            gadget [
-                    gadget support-input-methods? [
+                gadget support-input-methods? [
-                        gadget preedit? [
+                    gadget preedit? [
-                            gadget {
+                        gadget {
-                                [ preedit-start>> second ]
+                            [ preedit-start>> second ]
-                                [ preedit-end>> second ]
+                            [ preedit-end>> second ]
-                                [ preedit-start>> first ] [ editor-line ]
+                            [ preedit-start>> first ]
-                            } cleave subseq
+                            [ editor-line ]
-                            gadget [ remove-preedit-text ] [ remove-preedit-info ] bi
+                        } cleave subseq
-                            gadget user-input* drop
+                        gadget remove-preedit-text
-                        ] when
+                        gadget remove-preedit-info
-                        f gadget preedit-selection-mode?<<
+                        gadget user-input* drop
                     ] when
+                    f gadget preedit-selection-mode?<<
                 ] when
             ] when
-        ] ;
+        ] when
+    ] ;
 
     COCOA-METHOD: id validAttributesForMarkedText [
-            NSArray "NSMarkedClauseSegment" <NSString> send: \arrayWithObject:
+        NSArray "NSMarkedClauseSegment" <NSString> send: \arrayWithObject:
-        ] ;
+    ] ;
 
     COCOA-METHOD: id attributedSubstringForProposedRange: NSRange aRange
                                        actualRange: id actualRange [ f ] ;
@@ -609,26 +608,26 @@ PRIVATE>
 
     COCOA-METHOD: NSRect firstRectForCharacterRange: NSRange aRange
                                   actualRange: NSRange actualRange [
-            self window :> window
+        self window :> window
-            window [
+        window [
-                window world-focus :> gadget
+            window world-focus :> gadget
-                gadget [
+            gadget [
-                    gadget support-input-methods? [
+                gadget support-input-methods? [
-                        gadget editor-caret first gadget editor-line :> str
+                    gadget editor-caret first gadget editor-line :> str
-                        str aRange location>> >codepoint-index :> start-pos
+                    str aRange location>> >codepoint-index :> start-pos
-                        gadget editor-caret first start-pos 2array gadget loc>x
+                    gadget editor-caret first start-pos 2array gadget loc>x
-                        gadget caret-loc second gadget caret-dim second +
+                    gadget caret-loc second gadget caret-dim second +
-                        2array                     ! character pos
+                    2array                     ! character pos
-                        gadget screen-loc v+       ! + gadget pos 
+                    gadget screen-loc v+       ! + gadget pos
-                        { 1 -1 } v*
+                    { 1 -1 } v*
-                        window handle>> window>> dup send: frame send: contentRectForFrameRect:
+                    window handle>> window>> dup send: frame send: contentRectForFrameRect:
-                        CGRect-top-left 2array v+  ! + window pos
+                    CGRect-top-left 2array v+  ! + window pos
-                        first2 [ >fixnum ] bi@ 0 gadget line-height >fixnum
+                    first2 [ >fixnum ] bi@ 0 gadget line-height >fixnum
-                    ] [ 0 0 0 0 ] if
                 ] [ 0 0 0 0 ] if
             ] [ 0 0 0 0 ] if
-            <CGRect>
+        ] [ 0 0 0 0 ] if
-        ] ;
+        <CGRect>
+    ] ;
 
     COCOA-METHOD: void doCommandBySelector: SEL selector [ ] ;
 
@@ -641,10 +640,9 @@ PRIVATE>
         ] when
     ] ;
 
-
     COCOA-METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
     [
-        self frame pixelFormat super: \initWithFrame:pixelFormat:
+        self frame pixelFormat super: initWithFrame:pixelFormat:
         dup dup add-resize-observer
     ] ;
 
@@ -704,7 +702,7 @@ PRIVATE>
     [
 
         notification send: object dup selector: backingScaleFactor
-        send: \respondsToSelector: c-bool> [
+        send: respondsToSelector: c-bool> [
             { double { id SEL } } ?send: backingScaleFactor
 
             [ [ 1.0 > ] keep f ? gl-scale-factor set-global ]

extra/bittorrent/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/bittorrent/bittorrent-tests.factor

@@ -0,0 +1,10 @@
+USING: bittorrent io.sockets tools.test ;
+
+{
+    {
+        T{ inet4 { host "127.0.0.1" } { port 80 } }
+        T{ inet4 { host "1.1.1.1" } { port 443 } }
+    }
+} [
+    B{ 127 0 0 1 0x00 0x50 1 1 1 1 0x01 0xbb } parse-peer4s
+] unit-test

extra/bittorrent/bittorrent.factor

@@ -0,0 +1,277 @@
+! Copyright (C) 2020 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors arrays assocs bencode byte-arrays checksums
+checksums.sha combinators fry grouping http.client io io.binary
+io.encodings.binary io.files io.pathnames io.sockets
+io.streams.byte-array kernel literals make math math.bitwise
+math.parser math.ranges namespaces random sequences splitting
+strings urls ;
+
+IN: bittorrent
+
+<<
+CONSTANT: ALPHANUMERIC $[
+    [
+        CHAR: a CHAR: z [a,b] %
+        CHAR: A CHAR: Z [a,b] %
+        CHAR: 0 CHAR: 9 [a,b] %
+        ".-_~" %
+    ] { } make
+]
+
+: random-peer-id ( -- bytes )
+    20 [ ALPHANUMERIC random ] B{ } replicate-as ;
+>>
+
+SYMBOL: torrent-peer-id
+torrent-peer-id [ random-peer-id ] initialize
+
+SYMBOL: torrent-port
+torrent-port [ 6881 ] initialize
+
+
+! bitfield
+
+: bitfield-index ( n -- j i )
+    8 /mod 7 swap - ;
+
+: set-bitfield ( elt n bitfield -- )
+    [ bitfield-index rot ] dip -rot
+    '[ _ _ [ set-bit ] [ clear-bit ] if ] change-nth ;
+
+: check-bitfield ( n bitfield -- ? )
+    [ bitfield-index swap ] dip nth bit? ;
+
+
+! http
+
+: http-get-bencode ( url -- obj )
+    <get-request> BV{ } clone [
+        '[ _ push-all ] with-http-request* check-response drop
+    ] keep B{ } like bencode> ;
+
+
+! metainfo
+
+GENERIC: load-metainfo ( obj -- metainfo )
+
+M: url load-metainfo http-get-bencode ;
+
+M: pathname load-metainfo
+    binary [ read-bencode ] with-file-reader ;
+
+M: string load-metainfo
+    dup "http" head? [ >url ] [ <pathname> ] if load-metainfo ;
+
+: info-hash ( metainfo -- hash )
+    "info hash" swap dup '[
+        drop _ "info" of >bencode sha1 checksum-bytes
+    ] cache ;
+
+: announce-url ( metainfo -- url )
+    dup "announce-list" of [ nip first random ] [ "announce" of ] if* ;
+
+: scrape-url ( metainfo -- url/f )
+    announce-url "announce" over path>> subseq? [
+        [ "announce" "scrape" replace ] change-path
+    ] [ drop f ] if ;
+
+
+
+! tracker
+
+: tracker-url ( metainfo -- url )
+    {
+        [ announce-url >url ]
+        [
+            info-hash "info_hash" set-query-param
+            torrent-peer-id get "peer_id" set-query-param
+            torrent-port get "port" set-query-param
+            0 "uploaded" set-query-param
+            0 "downloaded" set-query-param
+            1 "compact" set-query-param
+        ]
+        [
+            { "info" "length" } [ of ] each
+            "left" set-query-param
+        ]
+    } cleave ;
+
+: parse-peer4 ( peerbin -- inet4 )
+    4 cut [
+        [ number>string ] { } map-as "." join
+    ] dip be> <inet4> ;
+
+: parse-peer4s ( peersbin -- inet4s )
+    dup array? [
+        [ [ "ip" of ] [ "port" of ] bi <inet4> ] map
+    ] [
+        6 <groups> [ parse-peer4 ] map
+    ] if ;
+
+: parse-peer6 ( peerbin -- inet6 )
+    16 cut [
+        2 <groups> [ be> number>string ] map ":" join
+    ] dip be> <inet6> ;
+
+: parse-peer6s ( peersbin -- inet6s )
+    18 <groups> [ parse-peer6 ] map ;
+
+: load-tracker ( torrent -- response )
+    tracker-url http-get-bencode
+    "peers" over [ parse-peer4s ] change-at ;
+
+: send-event ( torrent event -- response )
+    [ tracker-url ] [ "event" set-query-param ] bi*
+    http-get-bencode ;
+
+
+
+! messages
+
+TUPLE: handshake string reserved info-hash peer-id ;
+
+: <handshake> ( info-hash peer-id -- handshake )
+    handshake new
+        "BitTorrent protocol" >byte-array >>string
+        8 <byte-array> >>reserved
+        swap >>peer-id
+        swap >>info-hash ;
+
+: read-handshake ( -- handshake/f )
+    read1 [
+        [ 48 + read ] keep cut 8 cut 20 cut handshake boa
+    ] [ f ] if* ;
+
+: write-handshake ( handshake -- )
+    {
+        [ string>> [ length write1 ] [ write ] bi ]
+        [ reserved>> write ]
+        [ info-hash>> write ]
+        [ peer-id>> write ]
+    } cleave flush ;
+
+TUPLE: keep-alive ;
+TUPLE: choke ;
+TUPLE: unchoke ;
+TUPLE: interested ;
+TUPLE: not-interested ;
+TUPLE: have index ;
+TUPLE: bitfield bitfield ;
+TUPLE: request index begin length ;
+TUPLE: piece index begin block ;
+TUPLE: cancel index begin length ;
+TUPLE: port port ;
+TUPLE: suggest-piece index ;
+TUPLE: have-all ;
+TUPLE: have-none ;
+TUPLE: reject-request index begin length ;
+TUPLE: allowed-fast index ;
+TUPLE: extended id payload ;
+TUPLE: unknown id payload ;
+
+: read-int ( -- n/f ) 4 read [ be> ] [ f ] if* ;
+
+: parse-message ( bytes -- message/f )
+    unclip {
+        ! Core Protocol
+        { 0 [ drop choke boa ] }
+        { 1 [ drop unchoke boa ] }
+        { 2 [ drop interested boa ] }
+        { 3 [ drop not-interested boa ] }
+        { 4 [ 4 head be> have boa ] }
+        { 5 [ bitfield boa ] }
+        { 6 [ 4 cut 4 cut 4 head [ be> ] tri@ request boa ] }
+        { 7 [ 4 cut 4 cut [ [ be> ] bi@ ] dip piece boa ] }
+        { 8 [ 4 cut 4 cut 4 head [ be> ] tri@ cancel boa ] }
+
+        ! DHT Extension
+        { 9 [ be> port boa ] }
+
+        ! Fast Extensions
+        { 0x0D [ 4 head be> suggest-piece boa ] }
+        { 0x0E [ drop have-all boa ] }
+        { 0x0F [ drop have-none boa ] }
+        { 0x10 [ 4 cut 4 cut 4 head [ be> ] tri@ reject-request boa ] }
+        { 0x11 [ 4 head be> allowed-fast boa ] }
+
+        ! Extension Protocol
+        { 0x14 [ unclip swap extended boa ] }
+
+        ! Hash Transfer Protocol
+        ! { 0x15 [ "HashRequest" ] }
+        ! { 0x16 [ "Hashes" ] }
+        ! { 0x17 [ "HashReject" ] }
+        [ swap unknown boa ]
+    } case ;
+
+: read-message ( -- message )
+    read-int {
+        { f [ f ] }
+        { 0 [ keep-alive boa ] }
+        [ read [ parse-message ] [ f ] if* ]
+    } case ;
+
+: write-int ( n -- ) 4 >be write ;
+
+GENERIC: write-message ( message -- )
+
+M: keep-alive write-message drop 0 write-int ;
+
+M: choke write-message drop 1 write-int 0 write1 ;
+
+M: unchoke write-message drop 1 write-int 1 write1 ;
+
+M: interested write-message drop 1 write-int 2 write1 ;
+
+M: not-interested write-message drop 1 write-int 3 write1 ;
+
+M: have write-message
+    5 write-int 4 write1 index>> write-int ;
+
+M: bitfield write-message
+    field>> dup length 1 + write-int 5 write1 write ;
+
+M: request write-message
+    [ index>> ] [ begin>> ] [ length>> ] tri
+    13 write-int 6 write1 [ write-int ] tri@ ;
+
+M: piece write-message
+    [ index>> ] [ offset>> ] [ block>> ] tri
+    dup length 9 + write-int 7 write1
+    [ write-int ] [ write-int ] [ write ] tri* ;
+
+M: cancel write-message
+    [ index>> ] [ offset>> ] [ length>> ] tri
+    13 write-int 8 write1 [ write-int ] tri@ ;
+
+M: port write-message
+    5 write-int 9 write1 port>> write-int ;
+
+M: suggest-piece write-message
+    5 write-int 0x0D write1 index>> write-int ;
+
+M: have-all write-message drop 1 write-int 0x0E write1 ;
+
+M: have-none write-message drop 1 write-int 0x0F write1 ;
+
+M: reject-request write-message
+    [ index>> ] [ begin>> ] [ length>> ] tri
+    13 write-int 0x10 write1 [ write-int ] tri@ ;
+
+M: allowed-fast write-message
+    5 write-int 0x11 write1 index>> write-int ;
+
+M: extended write-message
+    [ payload>> ] [ id>> ] bi
+    over length 2 + write-int 0x14 write1 write1 write ;
+
+M: unknown write-message
+    [ payload>> ] [ id>> ] bi
+    over length 1 + write-int write1 write ;
+
+: >message ( bytes -- message )
+    binary [ read-message ] with-byte-reader ;
+
+: message> ( message -- bytes )
+    binary [ write-message ] with-byte-writer ;

extra/bittorrent/summary.txt

@@ -0,0 +1 @@
+BitTorent protocol for peer-to-peer file sharing.

vm/ffi_test.c

@@ -357,6 +357,41 @@ double ffi_test_65(int n, ...) {
     return sum;
 }
 
+unsigned long ffi_test_66(unsigned long a, unsigned long b, unsigned long c,
+                          struct test_struct_66 d, struct test_struct_66 e) {
+    unsigned long x;
+    x = a + b + c + d.mem1 + d.mem2 + e.mem1 + e.mem2;
+    return x;
+}
+
+unsigned long ffi_test_67(unsigned long a, unsigned long b, unsigned long c,
+                          struct test_struct_66 d, struct test_struct_66 e,
+                          unsigned long f) {
+    unsigned long x;
+    x = a + b + c + d.mem1 + d.mem2 + e.mem1 + e.mem2 + f*2;
+    return x;
+}
+
+unsigned long ffi_test_68(unsigned long a, unsigned long b, unsigned long c,
+                          struct test_struct_66 d, struct test_struct_68 e, struct test_struct_66 f) {
+    unsigned long x;
+    x = a + b + c + d.mem1 + d.mem2 + e.mem1 + e.mem2 + e.mem3 + f.mem1 + f.mem2;
+    return x;
+}
+
+unsigned long ffi_test_69(unsigned long a, unsigned long b, unsigned long c,
+                          struct test_struct_66 d, struct test_struct_69 e, struct test_struct_66 f) {
+    unsigned long x;
+    x = a + b + c + d.mem1 + d.mem2 + (long)e.mem1 + e.mem2 + e.mem3 + f.mem1 + f.mem2;
+    return x;
+}
+
+unsigned long ffi_test_70(struct test_struct_68 a, struct test_struct_68 b, struct test_struct_66 c) { 
+    unsigned long x;
+    x = a.mem1 + a.mem2 + a.mem3 + b.mem1 + b.mem2 + b.mem3 + c.mem1 + c.mem2;
+    return x;
+}
+
 
 void* bug1021_test_1(void* x, int y) {
   return (void*)(y * y + (size_t)x);

vm/ffi_test.def

@@ -1,5 +1,5 @@
 EXPORTS
-	ffi_test_0
+        ffi_test_0
         ffi_test_1
         ffi_test_2
         ffi_test_3
@@ -46,7 +46,7 @@ EXPORTS
         ffi_test_42
         ffi_test_43
         ffi_test_44
-	ffi_test_49
+        ffi_test_49
         ffi_test_50
         ffi_test_51
         ffi_test_52
@@ -62,6 +62,11 @@ EXPORTS
         ffi_test_63
         ffi_test_64
         ffi_test_65
+        ffi_test_66
+        ffi_test_67
+        ffi_test_68
+        ffi_test_69
+        ffi_test_70		
         bug1021_test_1
         bug1021_test_2
         bug1021_test_3

vm/ffi_test.h

@@ -232,6 +232,39 @@ FACTOR_EXPORT struct ulonglong_pair ffi_test_63(void);
 FACTOR_EXPORT int ffi_test_64(int n, ...);
 FACTOR_EXPORT double ffi_test_65(int n, ...);
 
+
+struct test_struct_66 {
+  unsigned long mem1;
+  unsigned long mem2;
+};
+
+struct test_struct_68 {
+  unsigned long mem1;
+  unsigned long mem2;
+  unsigned long mem3;  
+};
+
+struct test_struct_69 {
+  float         mem1;
+  unsigned long mem2;
+  unsigned long mem3;  
+};
+
+FACTOR_EXPORT unsigned long ffi_test_66(unsigned long a, unsigned long b, unsigned long c,
+                                        struct test_struct_66 d, struct test_struct_66 e);
+
+FACTOR_EXPORT unsigned long ffi_test_67(unsigned long a, unsigned long b, unsigned long c,
+                                        struct test_struct_66 d, struct test_struct_66 e, unsigned long f);
+
+FACTOR_EXPORT unsigned long ffi_test_68(unsigned long a, unsigned long b, unsigned long c,
+                                        struct test_struct_66 d, struct test_struct_68 e, struct test_struct_66 f);
+
+FACTOR_EXPORT unsigned long ffi_test_69(unsigned long a, unsigned long b, unsigned long c,
+                                        struct test_struct_66 d, struct test_struct_69 e, struct test_struct_66 f);
+
+FACTOR_EXPORT unsigned long ffi_test_70(struct test_struct_68 a, struct test_struct_68 b, struct test_struct_66 c);
+
+
 FACTOR_EXPORT void* bug1021_test_1(void* x, int y);
 FACTOR_EXPORT int bug1021_test_2(int x, char* y, void *z);
 FACTOR_EXPORT void* bug1021_test_3(int x);