diff --git a/LICENSE.txt b/LICENSE.txt index 9e25f74a59..fc4fbc9767 100644 --- a/LICENSE.txt +++ b/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 diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 50e2025ac7..f95914d257 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/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 diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index eb8361e845..697267e88d 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/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 } ; + heap-size cell align cell /i { int-rep f f } 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 ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index c9bdedb075..29835815e6 100644 --- a/basis/compiler/tests/alien.factor +++ b/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 diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 6a605e9d0b..f5df862848 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/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 -math.order sequences splitting system ; +cpu.x86.assembler cpu.x86.assembler.operands kernel layouts locals +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 ) - struct-types&offset split-struct [ +:: flatten-small-struct ( c-type -- seq ) + 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 <= ; diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 281ec6e3b8..34ebb56ba3 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/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 ] } @@ -193,7 +193,7 @@ IMPORT: NSAttributedString :: >codepoint-index ( str utf16-index -- codepoint-index ) 0 utf16-index 2 * str utf16n encode subseq utf16n decode length ; - + :: >utf16-index ( str codepoint-index -- utf16-index ) 0 codepoint-index str subseq utf16n encode length 2 / >integer ; @@ -238,28 +238,27 @@ IMPORT: NSAttributedString ] [ underlines ] if ; :: update-marked-text ( gadget str selectedRange replacementRange -- ) - replacementRange location>> NSNotFound = not ! [ - replacementRange length>> NSNotFound = not and [ ! erase this line + replacementRange location>> NSNotFound = [ 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 ] when - + gadget earlier-caret/mark dup gadget preedit-start<< 0 str length 2array v+ gadget preedit-end<< @@ -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,180 +457,180 @@ PRIVATE> ] [ 0 ] if ] ; + ! Text input COCOA-METHOD: void insertText: id text replacementRange: NSRange replacementRange [ - self window :> window - window [ + self 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 + + ] ; + + 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 + + ] ; + + 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 - 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 ] [ remove-preedit-info ] bi - str gadget user-input* drop - f gadget preedit-selection-mode?<< - ] [ - str window user-input - ] if - ] [ - str window user-input - ] if + gadget support-input-methods? [ + gadget str selectedRange replacementRange update-marked-text + underlines gadget preedit-underlines<< ] when ] 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 - - ] ; - - 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 - - ] ; - - 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 - ] when - ] when - ] ; - COCOA-METHOD: void unmarkText [ - self window :> window - window [ - window world-focus :> gadget - gadget [ - gadget support-input-methods? [ - gadget preedit? [ - gadget { - [ preedit-start>> second ] - [ preedit-end>> second ] - [ preedit-start>> first ] [ editor-line ] - } cleave subseq - gadget [ remove-preedit-text ] [ remove-preedit-info ] bi - gadget user-input* drop - ] when - f gadget preedit-selection-mode?<< + self window :> window + window [ + window world-focus :> gadget + gadget [ + gadget support-input-methods? [ + gadget preedit? [ + gadget { + [ preedit-start>> second ] + [ preedit-end>> second ] + [ preedit-start>> first ] + [ editor-line ] + } cleave subseq + gadget remove-preedit-text + gadget remove-preedit-info + gadget user-input* drop ] when + f gadget preedit-selection-mode?<< ] when ] when - ] ; - + ] when + ] ; + COCOA-METHOD: id validAttributesForMarkedText [ - NSArray "NSMarkedClauseSegment" send: \arrayWithObject: - ] ; + NSArray "NSMarkedClauseSegment" send: \arrayWithObject: + ] ; COCOA-METHOD: id attributedSubstringForProposedRange: NSRange aRange actualRange: id actualRange [ f ] ; - + COCOA-METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ] ; COCOA-METHOD: NSRect firstRectForCharacterRange: NSRange aRange actualRange: NSRange actualRange [ - self window :> window - window [ - window world-focus :> gadget - gadget [ - gadget support-input-methods? [ - gadget editor-caret first gadget editor-line :> str - str aRange location>> >codepoint-index :> start-pos - gadget editor-caret first start-pos 2array gadget loc>x - gadget caret-loc second gadget caret-dim second + - 2array ! character pos - gadget screen-loc v+ ! + gadget pos - { 1 -1 } v* - window handle>> window>> dup send: frame send: contentRectForFrameRect: - CGRect-top-left 2array v+ ! + window pos - first2 [ >fixnum ] bi@ 0 gadget line-height >fixnum - ] [ 0 0 0 0 ] if + self window :> window + window [ + window world-focus :> gadget + gadget [ + gadget support-input-methods? [ + gadget editor-caret first gadget editor-line :> str + str aRange location>> >codepoint-index :> start-pos + gadget editor-caret first start-pos 2array gadget loc>x + gadget caret-loc second gadget caret-dim second + + 2array ! character pos + gadget screen-loc v+ ! + gadget pos + { 1 -1 } v* + window handle>> window>> dup send: frame send: contentRectForFrameRect: + CGRect-top-left 2array v+ ! + window pos + first2 [ >fixnum ] bi@ 0 gadget line-height >fixnum ] [ 0 0 0 0 ] if ] [ 0 0 0 0 ] if - - ] ; + ] [ 0 0 0 0 ] if + + ] ; COCOA-METHOD: void doCommandBySelector: SEL selector [ ] ; - + ! Initialization COCOA-METHOD: void updateFactorGadgetSize: id notification [ @@ -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 ] diff --git a/extra/bittorrent/authors.txt b/extra/bittorrent/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/bittorrent/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/bittorrent/bittorrent-tests.factor b/extra/bittorrent/bittorrent-tests.factor new file mode 100644 index 0000000000..1c2e9585c6 --- /dev/null +++ b/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 diff --git a/extra/bittorrent/bittorrent.factor b/extra/bittorrent/bittorrent.factor new file mode 100644 index 0000000000..c831372b39 --- /dev/null +++ b/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 ) + 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 ] [ ] 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> ; + +: parse-peer4s ( peersbin -- inet4s ) + dup array? [ + [ [ "ip" of ] [ "port" of ] bi ] map + ] [ + 6 [ parse-peer4 ] map + ] if ; + +: parse-peer6 ( peerbin -- inet6 ) + 16 cut [ + 2 [ be> number>string ] map ":" join + ] dip be> ; + +: parse-peer6s ( peersbin -- inet6s ) + 18 [ 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 ; + +: ( info-hash peer-id -- handshake ) + handshake new + "BitTorrent protocol" >byte-array >>string + 8 >>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 ; diff --git a/extra/bittorrent/summary.txt b/extra/bittorrent/summary.txt new file mode 100644 index 0000000000..9275727d01 --- /dev/null +++ b/extra/bittorrent/summary.txt @@ -0,0 +1 @@ +BitTorent protocol for peer-to-peer file sharing. diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 1927a8d988..7e927b9d27 100644 --- a/vm/ffi_test.c +++ b/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); diff --git a/vm/ffi_test.def b/vm/ffi_test.def index fd5ff7b27e..4602bf92c4 100644 --- a/vm/ffi_test.def +++ b/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 diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 1c7ae7ddb3..0a78885f03 100644 --- a/vm/ffi_test.h +++ b/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);