From 5d6720f9916e7d1ada9bad5b38a0802368f6edca Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 21 Mar 2008 20:36:24 -0700 Subject: [PATCH 001/220] Unit tests for COM callbacks --- extra/windows/com/com-tests.factor | 162 ++++++++++++----------------- 1 file changed, 69 insertions(+), 93 deletions(-) diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 4a2f465fef..4c62e7adfd 100644 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,93 +1,69 @@ -USING: kernel windows.com windows.com.syntax windows.ole32 -alien alien.syntax tools.test libc alien.c-types arrays.lib -namespaces arrays continuations ; -IN: windows.com.tests - -! Create some test COM interfaces - -COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} - HRESULT returnOK ( ) - HRESULT returnError ( ) ; - -COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} - int getX ( ) - void setX ( int newX ) ; - -! Implement the IInherited interface in factor using alien-callbacks - -C-STRUCT: test-implementation - { "void*" "vtbl" } - { "int" "x" } ; - -: QueryInterface-callback - "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ] - alien-callback ; -: AddRef-callback - "ULONG" { "void*" } "stdcall" [ drop 2 ] - alien-callback ; -: Release-callback - "ULONG" { "void*" } "stdcall" [ drop 1 ] - alien-callback ; -: returnOK-callback - "HRESULT" { "void*" } "stdcall" [ drop S_OK ] - alien-callback ; -: returnError-callback - "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ] - alien-callback ; -: getX-callback - "int" { "void*" } "stdcall" [ test-implementation-x ] - alien-callback ; -: setX-callback - "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ] - alien-callback ; - -SYMBOL: +test-implementation-vtbl+ -SYMBOL: +guinea-pig-implementation+ - -: (make-test-implementation) ( x imp -- imp ) - [ set-test-implementation-x ] keep - +test-implementation-vtbl+ get over set-test-implementation-vtbl ; - -: ( x -- imp ) - "test-implementation" (make-test-implementation) ; - -: ( x -- imp ) - "test-implementation" heap-size malloc (make-test-implementation) ; - -QueryInterface-callback -AddRef-callback -Release-callback -returnOK-callback -returnError-callback -getX-callback -setX-callback -7 narray >c-void*-array -dup byte-length [ - [ byte-array>memory ] keep - +test-implementation-vtbl+ set - - ! Test that the words defined by COM-INTERFACE: do their magic - - "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test - "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test - "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test - S_OK 1array [ 0 ISimple::returnOK ] unit-test - E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test - 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test - - ! Test that the helper functions for QueryInterface, AddRef, Release work - - 0 +guinea-pig-implementation+ set - [ - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get com-add-ref - ] unit-test - - { } [ +guinea-pig-implementation+ get com-release ] unit-test - - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get IUnknown-iid com-query-interface - ] unit-test - - ] [ +guinea-pig-implementation+ get free ] [ ] cleanup -] with-malloc +USING: kernel windows.com windows.com.syntax windows.ole32 +alien alien.syntax tools.test libc alien.c-types arrays.lib +namespaces arrays continuations accessors ; +IN: windows.com.tests + +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} + int xPlus ( int y ) + int xMulAdd ( int mul, int add ) ; + +"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test +"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test +"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test + +SYMBOL: +test-vtbl+ +SYMBOL: +guinea-pig-implementation+ + +TUPLE: test-implementation x ; +C: test-implementation + +{ + { "IInherited" { + [ drop S_OK ] ! ISimple::returnOK + [ drop E_FAIL ] ! ISimple::returnError + [ x>> ] ! IInherited::getX + [ >>x drop ] ! IInherited::setX + } } + { "IUnrelated" { + [ swap x>> + ] ! IUnrelated::xPlus + [ spin x>> * + ] ! IUnrealted::xMulAdd + } } +} +dup +test-vtbl+ set [ + + 0 +test-vtbl+ get com-wrap + dup +guinea-pig-implementation+ set [ + + S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test + E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test + 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test + 420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test + 40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get com-add-ref + ] unit-test + + { } [ +guinea-pig-implementation+ get com-release ] unit-test + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get IUnknown-iid com-query-interface + ] unit-test + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get ISimple-iid com-query-interface + ] unit-test + "void*" heap-size +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get IUnrelated-iid com-query-interface + ] unit-test + + ] with-com-interface + +] [ free-com-vtbl ] [ ] cleanup From f2718f3a71fdb89d49e7a6aa46041ddecc5ff3d7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:31:46 -0700 Subject: [PATCH 002/220] Get COM wrappers working. dragdrop-listener example vocab to enable drag-and-drop on listener windows --- core/slots/slots-docs.factor | 2 +- extra/windows/com/com-docs.factor | 2 +- extra/windows/com/com-tests.factor | 44 +++++-- extra/windows/com/com.factor | 23 +++- extra/windows/com/syntax/syntax.factor | 10 +- extra/windows/com/wrapper/wrapper-docs.factor | 40 +++++++ extra/windows/com/wrapper/wrapper.factor | 111 ++++++++++++++++++ .../dragdrop-listener.factor | 70 +++++++++++ extra/windows/kernel32/kernel32.factor | 5 +- extra/windows/ole32/ole32.factor | 96 +++++++++++++-- extra/windows/shell32/shell32.factor | 14 ++- extra/windows/time/time.factor | 0 12 files changed, 386 insertions(+), 31 deletions(-) create mode 100755 extra/windows/com/wrapper/wrapper-docs.factor create mode 100755 extra/windows/com/wrapper/wrapper.factor create mode 100644 extra/windows/dragdrop-listener/dragdrop-listener.factor mode change 100755 => 100644 extra/windows/time/time.factor diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index e4bb307829..5de765313b 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors" } "In addition, two utility words are defined for each distinct slot name used in the system:" { $list - { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } + { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } } "Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor index 901a88675f..68663b4cdb 100644 --- a/extra/windows/com/com-docs.factor +++ b/extra/windows/com/com-docs.factor @@ -4,7 +4,7 @@ IN: windows.com HELP: com-query-interface { $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } } -{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ; +{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ; HELP: com-add-ref { $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 4c62e7adfd..e2685db1d0 100644 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,6 +1,7 @@ USING: kernel windows.com windows.com.syntax windows.ole32 alien alien.syntax tools.test libc alien.c-types arrays.lib -namespaces arrays continuations accessors ; +namespaces arrays continuations accessors math windows.com.wrapper +windows.com.wrapper.private ; IN: windows.com.tests COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} @@ -18,12 +19,16 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test +"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test -SYMBOL: +test-vtbl+ +SYMBOL: +test-wrapper+ SYMBOL: +guinea-pig-implementation+ +SYMBOL: +orig-wrapped-objects+ + ++wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global TUPLE: test-implementation x ; -C: test-implementation +C: test-implementation { { "IInherited" { @@ -36,17 +41,25 @@ C: test-implementation [ swap x>> + ] ! IUnrelated::xPlus [ spin x>> * + ] ! IUnrealted::xMulAdd } } -} -dup +test-vtbl+ set [ +} +dup +test-wrapper+ set [ - 0 +test-vtbl+ get com-wrap - dup +guinea-pig-implementation+ set [ + 0 swap com-wrap + dup +guinea-pig-implementation+ set [ drop S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test - 420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test - 40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test + 420 1array [ + +guinea-pig-implementation+ get + IUnrelated-iid com-query-interface + [ 20 20 IUnrelated::xMulAdd ] with-com-interface + ] unit-test + 40 1array [ + +guinea-pig-implementation+ get + IUnrelated-iid com-query-interface + [ 20 IUnrelated::xPlus ] with-com-interface + ] unit-test +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get com-add-ref @@ -56,14 +69,23 @@ dup +test-vtbl+ set [ +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get IUnknown-iid com-query-interface + dup com-release ] unit-test +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get ISimple-iid com-query-interface + dup com-release ] unit-test - "void*" heap-size +guinea-pig-implementation+ get 1array [ + "void*" heap-size +guinea-pig-implementation+ get + +guinea-pig-implementation+ get + 2array [ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface + dup ISimple-iid com-query-interface + over com-release dup com-release ] unit-test ] with-com-interface -] [ free-com-vtbl ] [ ] cleanup +] with-disposal + +! Ensure that we freed +guinea-pig-implementation ++orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor index b78d9b5b91..4833a7412a 100644 --- a/extra/windows/com/com.factor +++ b/extra/windows/com/com.factor @@ -1,12 +1,31 @@ USING: alien alien.c-types windows.com.syntax windows.ole32 -windows.types continuations kernel ; +windows.types continuations kernel alien.syntax ; IN: windows.com +LIBRARY: ole32 + COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) ULONG AddRef ( ) ULONG Release ( ) ; +COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} + HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT QueryGetData ( FORMATETC* pFormatetc ) + HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) + HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) + HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) + HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) + HRESULT DUnadvise ( DWORD pdwConnection ) + HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; + +COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} + HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragLeave ( ) + HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; + : com-query-interface ( interface iid -- interface' ) f [ IUnknown::QueryInterface ole32-error ] keep @@ -19,4 +38,4 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} IUnknown::Release drop ; inline : with-com-interface ( interface quot -- ) - [ keep ] [ com-release ] [ ] cleanup ; inline + over [ slip ] [ com-release ] [ ] cleanup ; inline diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 5884c18aee..216ca8707d 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -57,8 +57,12 @@ unless : (function-word) ( function interface -- word ) name>> "::" rot name>> 3append create-in ; -: all-functions ( definition -- functions ) - dup parent>> [ all-functions ] [ { } ] if* +: family-tree ( definition -- definitions ) + dup parent>> [ family-tree ] [ { } ] if* + swap add ; + +: family-tree-functions ( definition -- functions ) + dup parent>> [ family-tree-functions ] [ { } ] if* swap functions>> append ; : (define-word-for-function) ( function interface n -- ) @@ -71,7 +75,7 @@ unless [ [ (iid-word) ] [ iid>> 1quotation ] bi define ] [ name>> "com-interface" swap typedef ] [ - dup all-functions + dup family-tree-functions [ (define-word-for-function) ] with each-index ] tri ; diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor new file mode 100755 index 0000000000..51a3549047 --- /dev/null +++ b/extra/windows/com/wrapper/wrapper-docs.factor @@ -0,0 +1,40 @@ +USING: help.markup help.syntax io kernel math quotations +multiline alien windows.com windows.com.syntax continuations ; +IN: windows.com.wrapper + +HELP: +{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } +{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } +{ $code <" +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} + int xPlus ( int y ) + int xMulAdd ( int mul, int add ) ; + +{ + { "IInherited" { + [ drop S_OK ] ! ISimple::returnOK + [ drop E_FAIL ] ! ISimple::returnError + [ x>> ] ! IInherited::getX + [ >>x drop ] ! IInherited::setX + } } + { "IUnrelated" { + [ swap x>> + ] ! IUnrelated::xPlus + [ spin x>> * + ] ! IUnrealted::xMulAdd + } } +} +"> } ; + +HELP: com-wrap +{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } } +{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ; + +HELP: com-wrapper +{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } "." } ; diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor new file mode 100755 index 0000000000..890674ed6d --- /dev/null +++ b/extra/windows/com/wrapper/wrapper.factor @@ -0,0 +1,111 @@ +USING: alien alien.c-types windows.com.syntax +windows.com.syntax.private windows.com continuations kernel +sequences.lib namespaces windows.ole32 libc +assocs accessors arrays sequences quotations combinators +math combinators.cleave combinators.lib words compiler.units ; +IN: windows.com.wrapper + +TUPLE: com-wrapper vtbls freed? ; + +byte-array ] % + [ + >r find-com-interface-definition family-tree + r> 1quotation [ >r iid>> r> 2array ] curry map + ] map-index concat + [ f ] add , + \ case , + "void*" heap-size + [ * rot com-add-ref 0 rot set-void*-nth S_OK ] + curry , + [ nip f 0 rot set-void*-nth E_NOINTERFACE ] , + \ if* , + ] [ ] make ; + +: (make-add-ref) ( interfaces -- quot ) + length "void*" heap-size * [ swap + 0 over ulong-nth + 1+ [ 0 rot set-ulong-nth ] keep + ] curry ; + +: (make-release) ( interfaces -- quot ) + length "void*" heap-size * [ over + 0 over ulong-nth + 1- [ 0 rot set-ulong-nth ] keep + dup zero? [ swap (free-wrapped-object) ] [ nip ] if + ] curry ; + +: (make-iunknown-methods) ( interfaces -- quots ) + [ (make-query-interface) ] + [ (make-add-ref) ] + [ (make-release) ] tri + 3array ; + +: (thunk) ( n -- quot ) + dup 0 = + [ drop [ ] ] + [ "void*" heap-size neg * [ swap ] curry ] + if ; + +: (thunked-quots) ( quots iunknown-methods thunk -- quots' ) + [ [ swap 2array ] curry map swap ] keep + [ com-unwrap ] compose [ swap 2array ] curry map append ; + +: compile-alien-callback ( return parameters abi quot -- alien ) + [ alien-callback ] 4 ncurry + [ gensym [ swap define ] keep ] with-compilation-unit + execute ; + +: (make-vtbl) ( interface-name quots iunknown-methods n -- ) + (thunk) (thunked-quots) + swap find-com-interface-definition family-tree-functions [ + { return>> parameters>> } get-slots + dup length 1- roll [ + first dup empty? + [ 2drop [ ] ] + [ swap [ ndip ] 2curry ] + if + ] [ second ] bi compose + "stdcall" swap compile-alien-callback + ] 2map >c-void*-array [ byte-length malloc ] keep + over byte-array>memory ; + +: (make-vtbls) ( implementations -- vtbls ) + dup [ first ] map (make-iunknown-methods) + [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ; + +: (malloc-wrapped-object) ( wrapper -- wrapped-object ) + vtbls>> length "void*" heap-size * + [ "ulong" heap-size + malloc ] keep + over + 1 0 rot set-ulong-nth ; + +PRIVATE> + +: ( implementations -- wrapper ) + (make-vtbls) f com-wrapper construct-boa ; + +M: com-wrapper dispose + t >>freed? + vtbls>> [ free ] each ; + +: com-wrap ( object wrapper -- wrapped-object ) + dup (malloc-wrapped-object) >r vtbls>> r> + [ [ set-void*-nth ] curry each-index ] keep + [ +wrapped-objects+ get-global set-at ] keep ; diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor new file mode 100644 index 0000000000..a7851621ff --- /dev/null +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -0,0 +1,70 @@ +USING: windows.com windows.com.wrapper combinators.cleave +windows.kernel32 windows.ole32 windows.shell32 kernel accessors +prettyprint namespaces ui.tools.listener ui.tools.workspace +alien.c-types alien sequences math ; +IN: windows.dragdrop + +: filenames-from-hdrop ( hdrop -- filenames ) + dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files + [ + 2dup f 0 DragQueryFile 1+ ! get size of filename buffer + dup "WCHAR" + [ swap DragQueryFile drop ] keep + alien>u16-string + ] with map ; + +: filenames-from-data-object ( data-object -- filenames ) + "FORMATETC" + CF_HDROP over set-FORMATETC-cfFormat + f over set-FORMATETC-ptd + DVASPECT_CONTENT over set-FORMATETC-dwAspect + -1 over set-FORMATETC-lindex + TYMED_HGLOBAL over set-FORMATETC-tymed + "STGMEDIUM" + [ IDataObject::GetData ] keep swap succeeded? [ + dup STGMEDIUM-data + [ filenames-from-hdrop ] with-global-lock + swap ReleaseStgMedium + ] [ drop f ] if ; + +TUPLE: listener-dragdrop hWnd last-drop-effect ; + +: ( hWnd -- object ) + DROPEFFECT_NONE listener-dragdrop construct-boa ; + +SYMBOL: +listener-dragdrop-wrapper+ +{ + { "IDropTarget" { + [ ! DragEnter + >r 2drop + filenames-from-data-object + length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if + dup 0 r> set-ulong-nth + >>last-drop-effect drop + S_OK + ] [ ! DragOver + >r 2drop last-drop-effect>> 0 r> set-ulong-nth + S_OK + ] [ ! DragLeave + drop S_OK + ] [ ! Drop + >r 2drop nip + filenames-from-data-object + dup length 1 = [ + first unparse [ "USE: parser " % % " run-file" % ] "" make + eval-listener + DROPEFFECT_COPY + ] [ + 2drop DROPEFFECT_NONE + ] if + 0 r> set-ulong-nth + S_OK + ] + } } +} +listener-dragdrop-wrapper+ set-global + +: dragdrop-listener-window ( -- ) + get-workspace parent>> handle>> hWnd>> + dup + +listener-dragdrop-wrapper+ get-global com-wrap + [ RegisterDragDrop ole32-error ] with-com-interface ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 37b833cae1..5530c0871f 100644 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax windows.types ; +USING: alien alien.syntax kernel windows.types ; IN: windows.kernel32 : MAX_PATH 260 ; inline @@ -1564,3 +1564,6 @@ FUNCTION: BOOL WriteProcessMemory ( HANDLE hProcess, void* lpBaseAddress, void* ! FUNCTION: WriteTapemark ! FUNCTION: WTSGetActiveConsoleSessionId ! FUNCTION: ZombifyActCtx + +: with-global-lock ( HGLOBAL quot -- ) + swap [ GlobalLock swap call ] keep GlobalUnlock drop ; inline diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor index 44ea853af0..3be442514c 100644 --- a/extra/windows/ole32/ole32.factor +++ b/extra/windows/ole32/ole32.factor @@ -1,16 +1,10 @@ USING: alien alien.syntax alien.c-types math kernel sequences -windows windows.types combinators.lib ; +windows windows.kernel32 windows.types combinators.lib ; IN: windows.ole32 LIBRARY: ole32 -C-STRUCT: GUID - { "DWORD" "part1" } - { "DWORD" "part2" } - { "DWORD" "part3" } - { "DWORD" "part4" } ; - -TYPEDEF: void* REFGUID +TYPEDEF: GUID* REFGUID TYPEDEF: void* LPUNKNOWN TYPEDEF: ushort* LPOLESTR TYPEDEF: ushort* LPCOLESTR @@ -25,6 +19,7 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; : S_OK 0 ; inline : S_FALSE 1 ; inline +: E_NOINTERFACE HEX: 80004002 ; inline : E_FAIL HEX: 80004005 ; inline : E_INVALIDARG HEX: 80070057 ; inline @@ -40,11 +35,92 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; : DD_DEFDRAGDELAY 200 ; inline : DD_DEFDRAGMINDIST 2 ; inline -: ole32-error ( n -- ) - dup S_OK = [ +: CF_TEXT 1 ; inline +: CF_BITMAP 2 ; inline +: CF_METAFILEPICT 3 ; inline +: CF_SYLK 4 ; inline +: CF_DIF 5 ; inline +: CF_TIFF 6 ; inline +: CF_OEMTEXT 7 ; inline +: CF_DIB 8 ; inline +: CF_PALETTE 9 ; inline +: CF_PENDATA 10 ; inline +: CF_RIFF 11 ; inline +: CF_WAVE 12 ; inline +: CF_UNICODETEXT 13 ; inline +: CF_ENHMETAFILE 14 ; inline +: CF_HDROP 15 ; inline +: CF_LOCALE 16 ; inline +: CF_MAX 17 ; inline + +: CF_OWNERDISPLAY HEX: 0080 ; inline +: CF_DSPTEXT HEX: 0081 ; inline +: CF_DSPBITMAP HEX: 0082 ; inline +: CF_DSPMETAFILEPICT HEX: 0083 ; inline +: CF_DSPENHMETAFILE HEX: 008E ; inline + +: DVASPECT_CONTENT 1 ; inline +: DVASPECT_THUMBNAIL 2 ; inline +: DVASPECT_ICON 4 ; inline +: DVASPECT_DOCPRINT 8 ; inline + +: TYMED_HGLOBAL 1 ; inline +: TYMED_FILE 2 ; inline +: TYMED_ISTREAM 4 ; inline +: TYMED_ISTORAGE 8 ; inline +: TYMED_GDI 16 ; inline +: TYMED_MFPICT 32 ; inline +: TYMED_ENHMF 64 ; inline +: TYMED_NULL 0 ; inline + +C-STRUCT: DVTARGETDEVICE + { "DWORD" "tdSize" } + { "WORD" "tdDriverNameOffset" } + { "WORD" "tdDeviceNameOffset" } + { "WORD" "tdPortNameOffset" } + { "WORD" "tdExtDevmodeOffset" } + { "BYTE[1]" "tdData" } ; + +TYPEDEF: WORD CLIPFORMAT +TYPEDEF: POINT POINTL + +C-STRUCT: FORMATETC + { "CLIPFORMAT" "cfFormat" } + { "DVTARGETDEVICE*" "ptd" } + { "DWORD" "dwAspect" } + { "LONG" "lindex" } + { "DWORD" "tymed" } ; +TYPEDEF: FORMATETC* LPFORMATETC + +C-STRUCT: STGMEDIUM + { "DWORD" "tymed" } + { "void*" "data" } + { "LPUNKNOWN" "punkForRelease" } ; +TYPEDEF: STGMEDIUM* LPSTGMEDIUM + +: COINIT_MULTITHREADED 0 ; inline +: COINIT_APARTMENTTHREADED 2 ; inline +: COINIT_DISABLE_OLE1DDE 4 ; inline +: COINIT_SPEED_OVER_MEMORY 8 ; inline + +FUNCTION: HRESULT OleInitialize ( void* reserved ) ; +FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; + +FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; +FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; +FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; + +: succeeded? ( hresult -- ? ) + 0 HEX: 7FFFFFFF between? ; + +: ole32-error ( hresult -- ) + dup succeeded? [ drop ] [ (win32-error-string) throw ] if ; +: ole-initialize ( -- ) + f OleInitialize ole32-error ; + : guid= ( a b -- ? ) IsEqualGUID c-bool> ; diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor index d64fb68cb3..a5bed9daed 100644 --- a/extra/windows/shell32/shell32.factor +++ b/extra/windows/shell32/shell32.factor @@ -167,6 +167,15 @@ TYPEDEF: DWORD SHGDNF TYPEDEF: ULONG SFGAOF +C-STRUCT: DROPFILES + { "DWORD" "pFiles" } + { "POINT" "pt" } + { "BOOL" "fNC" } + { "BOOL" "fWide" } ; +TYPEDEF: DROPFILES* LPDROPFILES +TYPEDEF: DROPFILES* LPCDROPFILES +TYPEDEF: HANDLE HDROP + C-STRUCT: SHITEMID { "USHORT" "cb" } { "BYTE[1]" "abID" } ; @@ -210,5 +219,6 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046} FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ; -FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ; -: StrRetToBuf StrRetToBufW ; inline +FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ; +: DragQueryFile DragQueryFileW ; inline + diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor old mode 100755 new mode 100644 From 1c58671b9ed691dcd2545d5b692dd5979b4023da Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:34:58 -0700 Subject: [PATCH 003/220] Metadata files for windows.com.wrapper vocab --- extra/windows/com/wrapper/authors.txt | 1 + extra/windows/com/wrapper/summary.txt | 1 + extra/windows/com/wrapper/tags.txt | 3 +++ extra/windows/com/wrapper/wrapper-docs.factor | 0 extra/windows/com/wrapper/wrapper.factor | 0 5 files changed, 5 insertions(+) create mode 100644 extra/windows/com/wrapper/authors.txt create mode 100644 extra/windows/com/wrapper/summary.txt create mode 100644 extra/windows/com/wrapper/tags.txt mode change 100755 => 100644 extra/windows/com/wrapper/wrapper-docs.factor mode change 100755 => 100644 extra/windows/com/wrapper/wrapper.factor diff --git a/extra/windows/com/wrapper/authors.txt b/extra/windows/com/wrapper/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/windows/com/wrapper/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/wrapper/summary.txt b/extra/windows/com/wrapper/summary.txt new file mode 100644 index 0000000000..c43941984e --- /dev/null +++ b/extra/windows/com/wrapper/summary.txt @@ -0,0 +1 @@ +Wrap Factor objects with implementations of COM interfaces diff --git a/extra/windows/com/wrapper/tags.txt b/extra/windows/com/wrapper/tags.txt new file mode 100644 index 0000000000..ffb665dc8f --- /dev/null +++ b/extra/windows/com/wrapper/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor old mode 100755 new mode 100644 diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor old mode 100755 new mode 100644 From b5be6236c5c122b796c5b2451edfd785d959febd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:56:23 -0700 Subject: [PATCH 004/220] Remove combinators.cleave references from windows.com.wrapper and dragdrop-listener --- extra/windows/com/wrapper/wrapper.factor | 2 +- extra/windows/dragdrop-listener/dragdrop-listener.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 890674ed6d..7f63f529a6 100644 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel sequences.lib namespaces windows.ole32 libc assocs accessors arrays sequences quotations combinators -math combinators.cleave combinators.lib words compiler.units ; +math combinators.lib words compiler.units ; IN: windows.com.wrapper TUPLE: com-wrapper vtbls freed? ; diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor index a7851621ff..0776d37625 100644 --- a/extra/windows/dragdrop-listener/dragdrop-listener.factor +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -1,4 +1,4 @@ -USING: windows.com windows.com.wrapper combinators.cleave +USING: windows.com windows.com.wrapper combinators windows.kernel32 windows.ole32 windows.shell32 kernel accessors prettyprint namespaces ui.tools.listener ui.tools.workspace alien.c-types alien sequences math ; From 71b58d1a2a4813f101c9977ca8621f3308223ea5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 13:13:16 -0700 Subject: [PATCH 005/220] Fix name of windows.dragdrop-listener vocab --- extra/windows/dragdrop-listener/dragdrop-listener.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor index 0776d37625..8384bb1acc 100644 --- a/extra/windows/dragdrop-listener/dragdrop-listener.factor +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -2,7 +2,7 @@ USING: windows.com windows.com.wrapper combinators windows.kernel32 windows.ole32 windows.shell32 kernel accessors prettyprint namespaces ui.tools.listener ui.tools.workspace alien.c-types alien sequences math ; -IN: windows.dragdrop +IN: windows.dragdrop-listener : filenames-from-hdrop ( hdrop -- filenames ) dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files @@ -54,9 +54,7 @@ SYMBOL: +listener-dragdrop-wrapper+ first unparse [ "USE: parser " % % " run-file" % ] "" make eval-listener DROPEFFECT_COPY - ] [ - 2drop DROPEFFECT_NONE - ] if + ] [ 2drop DROPEFFECT_NONE ] if 0 r> set-ulong-nth S_OK ] From 2045f44ced34a546d215c872cda542171014a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:08:49 -0500 Subject: [PATCH 006/220] Fix RSS unit tests --- extra/rss/rss-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 7523d0509f..252defe99b 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -5,7 +5,7 @@ IN: rss.tests : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - utf8 read-feed ; + utf8 file-contents read-feed ; [ T{ feed @@ -36,7 +36,7 @@ IN: rss.tests "http://example.org/2005/04/02/atom" "\n
\n

[Update: The Atom draft is finished.]

\n
\n " - T{ timestamp f 2003 12 13 8 29 29 -4 } + T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test From 2f2d31a623785b936e7fc7b18fc72af34ab0792e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:53:42 -0500 Subject: [PATCH 007/220] Fix HTTP unit tests --- extra/http/http-tests.factor | 15 +++++++++------ extra/http/http.factor | 3 +-- extra/http/server/actions/actions-tests.factor | 10 +++++++--- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9302045624..3a50630335 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -24,6 +24,8 @@ IN: http.tests [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test +: lf>crlf "\n" split "\r\n" join ; + STRING: read-request-test-1 GET http://foo/bar HTTP/1.1 Some-Header: 1 @@ -45,7 +47,7 @@ blah cookies: V{ } } ] [ - read-request-test-1 [ + read-request-test-1 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -59,7 +61,7 @@ blah ; read-request-test-1' 1array [ - read-request-test-1 + read-request-test-1 lf>crlf [ read-request ] with-string-reader [ write-request ] with-string-writer ! normalize crlf @@ -69,6 +71,7 @@ read-request-test-1' 1array [ STRING: read-request-test-2 HEAD http://foo/bar HTTP/1.1 Host: www.sex.com + ; [ @@ -83,7 +86,7 @@ Host: www.sex.com cookies: V{ } } ] [ - read-request-test-2 [ + read-request-test-2 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -104,7 +107,7 @@ blah cookies: V{ } } ] [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader ] unit-test @@ -117,7 +120,7 @@ content-type: text/html ; read-response-test-1' 1array [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader [ write-response ] with-string-writer ! normalize crlf @@ -162,7 +165,7 @@ io.encodings.ascii ; "localhost" 1237 ascii [ "GET nested HTTP/1.0\r\n" write flush "\r\n" write flush - readln drop + read-crlf drop read-header ] with-stream "location" swap at "/" head? ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4aaab2205e..3e81fccd24 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -89,8 +89,7 @@ IN: http : read-crlf ( -- string ) "\r" read-until - CHAR: \r assert= - read1 CHAR: \n assert= ; + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; : read-header-line ( -- ) read-crlf dup diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index ebf8e8770b..90e632d7f5 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ IN: http.server.actions.tests USING: http.server.actions http.server.validators tools.test math math.parser multiline namespaces http -io.streams.string http.server sequences accessors ; +io.streams.string http.server sequences splitting accessors ; [ "a" [ v-number ] { { "a" "123" } } validate-param @@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ; { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params "action-1" set +: lf>crlf "\n" split "\r\n" join ; + STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -20,7 +22,8 @@ blah ; [ 25 ] [ - action-request-test-1 [ read-request ] with-string-reader + action-request-test-1 lf>crlf + [ read-request ] with-string-reader request set "/blah" "action-1" get call-responder @@ -40,7 +43,8 @@ xxx=4 ; [ "/blahXXXX" ] [ - action-request-test-2 [ read-request ] with-string-reader + action-request-test-2 lf>crlf + [ read-request ] with-string-reader request set "/blah" "action-2" get call-responder From 3be7f29b25c5a939521b0f1b61de480237dd921c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:54:41 -0500 Subject: [PATCH 008/220] Fix todo load error --- extra/webapps/todo/todo.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 08555b92ed..97af356dc5 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -6,6 +6,7 @@ http.server.components http.server.components.farkup http.server.forms http.server.templating.chloe http.server.boilerplate http.server.crud http.server.auth http.server.actions http.server.db +http.server.auth.login http.server webapps.factor-website ; IN: webapps.todo @@ -78,8 +79,6 @@ TUPLE: todo-responder < dispatcher ; : init-todo ( -- ) test-db [ init-todo-table - init-users-table - init-sessions-table ] with-db From 04e9b1c37fb0c72f06e86e1ba2a42ae8e56a6ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:31:32 -0500 Subject: [PATCH 009/220] Fix Cocoa UI bug --- extra/ui/cocoa/views/views.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 5b975f40de..442eda90ef 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -126,6 +126,13 @@ CLASS: { { +name+ "FactorView" } { +protocols+ { "NSTextInput" } } } + +! Rendering +! Rendering +{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } + [ 3drop window relayout-1 ] +} + ! Events { "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } [ 3drop 1 ] From 3a69c972980251af21c731f771d0e61625593bb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:42:30 -0500 Subject: [PATCH 010/220] https:// is absolute --- extra/http/client/client.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8879a76a5c..cc356ca8e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -39,13 +39,16 @@ DEFER: http-request SYMBOL: redirects +: absolute-url? ( url -- ? ) + [ "http://" head? ] [ "https://" head? ] bi or ; + : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ stdio get dispose redirects inc redirects get max-redirects < [ header>> "location" swap at - dup "http://" head? [ + dup absolute-url? [ absolute-redirect ] [ relative-redirect @@ -116,8 +119,12 @@ M: download-failed error. : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream swap check-response - [ swap latin1 stream-copy ] with-disposal ; + swap http-get-stream check-response + dup string? [ + latin1 [ write ] with-file-writer + ] [ + [ swap latin1 stream-copy ] with-disposal + ] if ; : download ( url -- ) dup download-name download-to ; From df41c8b68f44a04209ef484a8f689f358266159c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 02:46:35 -0500 Subject: [PATCH 011/220] Fix documentation --- core/alien/strings/strings-docs.factor | 4 ++-- core/alien/strings/strings.factor | 2 +- extra/bit-vectors/bit-vectors-docs.factor | 4 ++-- extra/byte-vectors/byte-vectors-docs.factor | 2 +- extra/columns/columns-docs.factor | 2 +- extra/float-vectors/float-vectors-docs.factor | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor index 0dbb4ffd38..27b0122ebe 100644 --- a/core/alien/strings/strings-docs.factor +++ b/core/alien/strings/strings-docs.factor @@ -3,14 +3,14 @@ debugger ; IN: alien.strings HELP: string>alien -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } } +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } { $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } { $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; { string>alien alien>string malloc-string } related-words HELP: alien>string -{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } } +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } { $description "Reads a null-terminated C string from the specified address with the given encoding." } ; HELP: malloc-string diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 463fc11e0d..d69d8e9e8e 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -6,7 +6,7 @@ io.streams.byte-array io.streams.memory io.encodings.utf8 io.encodings.utf16 system alien strings cpu.architecture ; IN: alien.strings -GENERIC# alien>string 1 ( alien encoding -- string/f ) +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) M: c-ptr alien>string >r r> diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor index 9ceb2df342..41f32b4cdb 100755 --- a/extra/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -3,7 +3,7 @@ bit-vectors.private combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" -"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." +"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." $nl "Bit vectors form a class:" { $subsection bit-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "bit-vectors" HELP: bit-vector -{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; +{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor index f34bc20219..139cbab822 100755 --- a/extra/byte-vectors/byte-vectors-docs.factor +++ b/extra/byte-vectors/byte-vectors-docs.factor @@ -19,7 +19,7 @@ $nl ABOUT: "byte-vectors" HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor index 6b2adce9d9..a2f0cccf3b 100644 --- a/extra/columns/columns-docs.factor +++ b/extra/columns/columns-docs.factor @@ -14,7 +14,7 @@ HELP: ( seq n -- column ) { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example - "USING: arrays prettyprint sequences ;" + "USING: arrays prettyprint columns ;" "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." "{ 1 4 7 }" } diff --git a/extra/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor index 8d25da54be..5e06f05a2b 100755 --- a/extra/float-vectors/float-vectors-docs.factor +++ b/extra/float-vectors/float-vectors-docs.factor @@ -3,7 +3,7 @@ float-vectors.private combinators ; IN: float-vectors ARTICLE: "float-vectors" "Float vectors" -"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." +"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." $nl "Float vectors form a class:" { $subsection float-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "float-vectors" HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; +{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } From d2d2c5d84fbf6eaa2c5150067fd19dc8f6a314c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:00:04 -0500 Subject: [PATCH 012/220] fix using in hardware-info --- extra/hardware-info/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 10474c09f7..3162496974 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader hardware-info.backend -system ; +system alien.strings ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) From 8a0909d84923ce59a47e5322e449eb1c149d2768 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:09:36 -0500 Subject: [PATCH 013/220] fix ffi test int ffi test 36 point 5 --- core/alien/compiler/compiler-tests.factor | 750 +++++++++++----------- vm/ffi_test.c | 2 +- 2 files changed, 376 insertions(+), 376 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 3d0f36e415..57bf163443 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,375 +1,375 @@ -IN: alien.compiler.tests -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test math ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -FUNCTION: int ffi_test_2 int x int y ; -[ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] must-fail - -FUNCTION: int ffi_test_3 int x int y int z int t ; -[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; -[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail -[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -FUNCTION: char* ffi_test_15 char* x char* y ; - -[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test -[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] must-fail - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -FUNCTION: tiny ffi_test_17 int x ; - -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test - -[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] must-infer-as - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] must-fail - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect gc ; - -{ 3 1 } [ indirect-test-2 ] must-infer-as - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] unit-test - -FUNCTION: double ffi_test_6 float x float y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] must-fail - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -FUNCTION: long ffi_test_22 long x longlong y longlong z ; - -[ 987655432 ] -[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test - -[ 1111 f 123456789 ffi_test_22 ] must-fail - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; - -[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test - -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -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" - 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" - 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" - 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" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; - -: make-struct-12 - "test-struct-12" - [ set-test-struct-12-x ] keep ; - -FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; - -[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test - -FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; - -[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] with-string-writer -] unit-test - -: callback-5 - "void" { } "cdecl" [ gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -! cpu "arm" = [ -! [ "testing" ] [ -! "testing" callback-5a callback_test_1 -! ] unit-test -! ] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test - -: callback-9 - "int" { "int" "int" "int" } "cdecl" [ - + + 1+ - ] alien-callback ; - -FUNCTION: void ffi_test_36_point_5 ( ) ; - -[ ] [ ffi_test_36_point_5 ] unit-test - -FUNCTION: int ffi_test_37 ( void* func ) ; - -[ 1 ] [ callback-9 ffi_test_37 ] unit-test - -[ 7 ] [ callback-9 ffi_test_37 ] unit-test +IN: alien.compiler.tests +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test math ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "hi" 3 ffi_test_2 ] must-fail + +FUNCTION: int ffi_test_3 int x int y int z int t ; +[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; +[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +FUNCTION: char* ffi_test_15 char* x char* y ; + +[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test +[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test +[ 1 2 ffi_test_15 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] unit-test + +FUNCTION: double ffi_test_6 float x float y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test +[ "a" "b" ffi_test_6 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +FUNCTION: long ffi_test_22 long x longlong y longlong z ; + +[ 987655432 ] +[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test + +[ 1111 f 123456789 ffi_test_22 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; + +[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test + +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +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" + 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" + 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" + 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" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + +[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] with-string-writer +] unit-test + +: callback-5 + "void" { } "cdecl" [ gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +! cpu "arm" = [ +! [ "testing" ] [ +! "testing" callback-5a callback_test_1 +! ] unit-test +! ] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test + +: callback-9 + "int" { "int" "int" "int" } "cdecl" [ + + + 1+ + ] alien-callback ; + +FUNCTION: void int_ffi_test_36_point_5 ( ) ; + +[ ] [ int_ffi_test_36_point_5 ] unit-test + +FUNCTION: int ffi_test_37 ( void* func ) ; + +[ 1 ] [ callback-9 ffi_test_37 ] unit-test + +[ 7 ] [ callback-9 ffi_test_37 ] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index b2cbf9b6b5..4293a6bbae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x) static int global_var; -void ffi_test_36_point_5(void) +void int_ffi_test_36_point_5(void) { printf("int_ffi_test_36_point_5\n"); global_var = 0; From defc1cfae97329b0aade66049093235a32485601 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Apr 2008 21:55:26 -0500 Subject: [PATCH 014/220] fix sql --- extra/db/sql/sql-tests.factor | 2 +- extra/db/sql/sql.factor | 34 +++++++++++++++++----------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 488026fcc7..db69d71a84 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -28,7 +28,7 @@ TUPLE: person name age ; { select { columns "salary" } { from "staff" } - { where { "branchno" "b003" } } + { where { "branchno" = "b003" } } } } { "branchno" > 3 } } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 26e8429efd..b0ec7aaf34 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -27,23 +27,23 @@ DEFER: sql% : sql-array% ( array -- ) unclip { - { columns [ "," (sql-interleave) ] } - { from [ "from" "," sql-interleave ] } - { where [ "where" "and" sql-interleave ] } - { group-by [ "group by" "," sql-interleave ] } - { having [ "having" "," sql-interleave ] } - { order-by [ "order by" "," sql-interleave ] } - { offset [ "offset" sql% sql% ] } - { limit [ "limit" sql% sql% ] } - { select [ "(select" sql% sql% ")" sql% ] } - { table [ sql% ] } - { set [ "set" "," sql-interleave ] } - { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } - { count [ "count" sql-function, ] } - { sum [ "sum" sql-function, ] } - { avg [ "avg" sql-function, ] } - { min [ "min" sql-function, ] } - { max [ "max" sql-function, ] } + { \ columns [ "," (sql-interleave) ] } + { \ from [ "from" "," sql-interleave ] } + { \ where [ "where" "and" sql-interleave ] } + { \ group-by [ "group by" "," sql-interleave ] } + { \ having [ "having" "," sql-interleave ] } + { \ order-by [ "order by" "," sql-interleave ] } + { \ offset [ "offset" sql% sql% ] } + { \ limit [ "limit" sql% sql% ] } + { \ select [ "(select" sql% sql% ")" sql% ] } + { \ table [ sql% ] } + { \ set [ "set" "," sql-interleave ] } + { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ count [ "count" sql-function, ] } + { \ sum [ "sum" sql-function, ] } + { \ avg [ "avg" sql-function, ] } + { \ min [ "min" sql-function, ] } + { \ max [ "max" sql-function, ] } [ sql% [ sql% ] each ] } case ; From b2e90f62c0c88ca915848463d86165dc4f26e8ed Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:36:58 -0700 Subject: [PATCH 015/220] Modernize some code in the bunny demo --- extra/bunny/bunny.factor | 35 ++++++------- extra/bunny/outlined/outlined.factor | 16 +++--- extra/opengl/demo-support/demo-support.factor | 50 ++++++++++++------- 3 files changed, 53 insertions(+), 48 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 43b9edcd00..6efa739677 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib float-arrays continuations opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model ; +bunny.cel-shaded bunny.outlined bunny.model accessors ; IN: bunny TUPLE: bunny-gadget model geom draw-seq draw-n ; @@ -17,34 +17,29 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ; } bunny-gadget construct ; : bunny-gadget-draw ( gadget -- draw ) - { bunny-gadget-draw-n bunny-gadget-draw-seq } + { draw-n>> draw-seq>> } get-slots nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { bunny-gadget-draw-seq bunny-gadget-draw-n } + dup { draw-seq>> draw-n>> } get-slots 1+ swap length mod - swap [ set-bunny-gadget-draw-n ] keep relayout-1 ; + >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup bunny-gadget-model - over { - [ ] - [ ] - [ ] - } map-call-with [ ] subset - 0 - roll { - set-bunny-gadget-geom - set-bunny-gadget-draw-seq - set-bunny-gadget-draw-n - } set-slots ; + dup model>> >>geom + dup + [ ] + [ ] + [ ] tri 3array + [ ] subset >>draw-seq + 0 >>draw-n + drop ; M: bunny-gadget ungraft* ( gadget -- ) - { bunny-gadget-geom bunny-gadget-draw-seq } get-slots - [ [ dispose ] when* ] each - [ dispose ] when* ; + [ geom>> [ dispose ] when* ] + [ draw-seq>> [ [ dispose ] when* ] each ] bi ; M: bunny-gadget draw-gadget* ( gadget -- ) 0.15 0.15 0.15 1.0 glClearColor @@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { bunny-gadget-geom bunny-gadget-draw } get-slots + { geom>> bunny-gadget-draw } get-slots draw-bunny ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6a2f54cceb..85202e4185 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -183,8 +183,7 @@ TUPLE: bunny-outlined dup bunny-outlined-gadget rect-dim over bunny-outlined-framebuffer-dim over = - [ 2drop ] - [ + [ 2drop ] [ swap dup dispose-framebuffer >r dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) @@ -228,12 +227,11 @@ TUPLE: bunny-outlined } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ; M: bunny-outlined draw-bunny - dup remake-framebuffer-if-needed - [ (pass1) ] keep (pass2) ; + [ remake-framebuffer-if-needed ] + [ (pass1) ] + [ (pass2) ] tri ; M: bunny-outlined dispose - { - [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] - [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ dispose-framebuffer ] - } cleave ; + [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] + [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] + [ dispose-framebuffer ] tri diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 84515305c8..524567b5bd 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -2,13 +2,9 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; IN: opengl.demo-support -: NEAR-PLANE 1.0 64.0 / ; inline -: FAR-PLANE 4.0 ; inline : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline -: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline : KEY-ROTATE-STEP 1.0 ; inline -: KEY-DISTANCE-STEP 1.0 64.0 / ; inline : DIMS { 640 480 } ; inline : FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ; @@ -21,6 +17,17 @@ TUPLE: demo-gadget yaw pitch distance ; demo-gadget construct-gadget [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ; +GENERIC: far-plane ( gadget -- z ) +GENERIC: near-plane ( gadget -- z ) +GENERIC: distance-step ( gadget -- dz ) + +M: demo-gadget far-plane ( gadget -- z ) + drop 4.0 ; +M: demo-gadget near-plane ( gadget -- z ) + drop 1.0 64.0 / ; +M: demo-gadget distance-step ( gadget -- dz ) + drop 1.0 64.0 / ; + : yaw-demo-gadget ( yaw gadget -- ) [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; @@ -36,21 +43,26 @@ M: demo-gadget pref-dim* ( gadget -- dim ) : -+ ( x -- -x x ) dup neg swap ; -: demo-gadget-frustum ( -- -x x -y y near far ) - FOV-RATIO NEAR-PLANE FOV / v*n - first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ; +: demo-gadget-frustum ( gadget -- -x x -y y near far ) + [ near-plane ] [ far-plane ] bi [ + drop FOV-RATIO swap FOV / v*n + first2 [ -+ ] bi@ + ] 2keep ; : demo-gadget-set-matrices ( gadget -- ) - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] - tri ; + [ + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-gadget-frustum glFrustum + ] [ + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] + [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] + [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + tri + ] bi ; : reset-last-drag-rel ( -- ) { 0 0 } last-drag-loc set-global ; @@ -65,11 +77,11 @@ demo-gadget H{ { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } - { T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] } + { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } + { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } - { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] } + { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } } set-gestures From 7a9f379944698ac8a67658b03f8cd907df84bbf2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:37:34 -0700 Subject: [PATCH 016/220] Add spheres demo --- extra/spheres/spheres.factor | 233 +++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) create mode 100644 extra/spheres/spheres.factor diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor new file mode 100644 index 0000000000..d8ecb2da98 --- /dev/null +++ b/extra/spheres/spheres.factor @@ -0,0 +1,233 @@ +USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers +opengl multiline ui.gadgets accessors sequences ui.render ui math +arrays.lib combinators ; +IN: spheres + +STRING: plane-vertex-shader +varying vec3 object_position; +void +main() +{ + object_position = gl_Vertex.xyz; + gl_Position = ftransform(); +} +; + +STRING: plane-fragment-shader +varying vec3 object_position; +void +main() +{ + float distance_factor = (gl_FragCoord.z * 0.5 + 0.5); + distance_factor = pow(distance_factor, 500.0)*0.5; + + gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0 + ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0) + : vec4(1.0, distance_factor, distance_factor, 1.0); +} +; + +STRING: sphere-vertex-shader +attribute vec3 center; +attribute float radius; +attribute vec4 surface_color; +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position, vcolor; + +void +main() +{ + world_position = gl_ModelViewMatrix * vec4(center, 1); + sphere_position = gl_Vertex.xyz; + + gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0)); + + vcolor = surface_color; + vradius = radius; +} +; + +STRING: sphere-fragment-shader +uniform vec3 light_position; +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position, vcolor; + +vec4 ambient = vec4(0.3, 0.2, 0.2, 1.0); +vec4 diffuse = vec4(0.7, 0.8, 0.8, 1.0); + +vec4 +light(vec3 point, vec3 normal) +{ + vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz; + vec3 direction = normalize(transformed_light_position - point); + float d = max(0.0, dot(normal, direction)); + + return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a); +} + +void +main() +{ + float radius = length(sphere_position); + if(radius > 1.0) discard; + + vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius)); + vec4 world_surface = world_position + vec4(surface * vradius, 0); + vec4 transformed_surface = gl_ProjectionMatrix * world_surface; + + gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5; + gl_FragColor = light(world_surface.xyz, surface); +} +; + +TUPLE: spheres-gadget + plane-program sphere-program + reflection-framebuffer reflection-depthbuffer + reflection-texture ; + +: ( -- gadget ) + 0.0 0.0 20.0 + { set-delegate } spheres-gadget construct ; + +M: spheres-gadget near-plane ( gadget -- z ) + drop 1.0 ; +M: spheres-gadget far-plane ( gadget -- z ) + drop 512.0 ; +M: spheres-gadget distance-step ( gadget -- dz ) + drop 0.5 ; + +: (make-reflection-texture) ( -- texture ) + gen-texture [ + GL_TEXTURE_CUBE_MAP swap glBindTexture + GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + [ 0 GL_RGBA8 1024 1024 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] + each + ] keep ; + +: (make-reflection-depthbuffer) ( -- depthbuffer ) + gen-renderbuffer [ + GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT + GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 1024 1024 glRenderbufferStorageEXT + ] keep ; + +: (make-reflection-framebuffer) ( depthbuffer -- framebuffer ) + gen-framebuffer dup [ + swap >r + GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r> + glFramebufferRenderbufferEXT + ] with-framebuffer ; + +M: spheres-gadget graft* ( gadget -- ) + plane-vertex-shader plane-fragment-shader + >>plane-program + sphere-vertex-shader sphere-fragment-shader + >>sphere-program + (make-reflection-texture) >>reflection-texture + (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep + (make-reflection-framebuffer) >>reflection-framebuffer + drop ; + +M: spheres-gadget ungraft* ( gadget -- ) + { + [ reflection-framebuffer>> [ delete-framebuffer ] when* ] + [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] + [ reflection-texture>> [ delete-texture ] when* ] + [ sphere-program>> [ delete-gl-program ] when* ] + [ plane-program>> [ delete-gl-program ] when* ] + } cleave ; + +M: spheres-gadget pref-dim* ( gadget -- dim ) + drop { 640 480 } ; + +: (draw-sphere) ( program center radius surfacecolor -- ) + roll + [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ] + [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ] + [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ] + tri tri* + { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; + +: sphere-scene ( gadget -- ) + GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor + glClear + [ + sphere-program>> dup { + { "light_position" [ 0.0 0.0 100.0 glUniform3f ] } + } [ + [ { 0.0 0.0 0.0 } 4.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] + [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] tri + ] with-gl-program + ] [ + plane-program>> { } [ + GL_QUADS [ + -1000.0 -30.0 1000.0 glVertex3f + -1000.0 -30.0 -1000.0 glVertex3f + 1000.0 -30.0 -1000.0 glVertex3f + 1000.0 -30.0 1000.0 glVertex3f + ] do-state + ] with-gl-program + ] bi ; + +: reflection-frustum ( gadget -- -x x -y y near far ) + [ near-plane ] [ far-plane ] bi [ + drop dup [ -+ ] bi@ + ] 2keep ; + +: (reflection-face) ( gadget face -- ) + swap reflection-texture>> >r >r + GL_FRAMEBUFFER_EXT + GL_COLOR_ATTACHMENT0_EXT + r> r> 0 glFramebufferTexture2DEXT ; + +M: spheres-gadget draw-gadget* ( gadget -- ) + GL_DEPTH_TEST glEnable + 0.15 0.15 1.0 1.0 glClearColor { + [ + GL_PROJECTION glMatrixMode + glLoadIdentity + reflection-frustum glFrustum + GL_MODELVIEW glMatrixMode + glLoadIdentity + glPushMatrix + ] + [ + dup reflection-framebuffer>> [ { + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) + glPopMatrix glPushMatrix + 90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) + glPopMatrix + -90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + } cleave ] with-framebuffer + ] + [ demo-gadget-set-matrices ] + [ sphere-scene ] + } cleave ; + +: spheres-window ( -- ) + [ "Spheres" open-window ] with-ui ; + +MAIN: spheres-window From b26eadc5ea12599ebe4ed3b2bb370ebe34b774dd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:39:12 -0700 Subject: [PATCH 017/220] Metadata for spheres vocab --- extra/spheres/authors.txt | 1 + extra/spheres/summary.txt | 1 + extra/spheres/tags.txt | 2 ++ 3 files changed, 4 insertions(+) create mode 100644 extra/spheres/authors.txt create mode 100644 extra/spheres/summary.txt create mode 100644 extra/spheres/tags.txt diff --git a/extra/spheres/authors.txt b/extra/spheres/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/spheres/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/spheres/summary.txt b/extra/spheres/summary.txt new file mode 100644 index 0000000000..fd97091e33 --- /dev/null +++ b/extra/spheres/summary.txt @@ -0,0 +1 @@ +Draw pixel-perfect spheres using GLSL shaders \ No newline at end of file diff --git a/extra/spheres/tags.txt b/extra/spheres/tags.txt new file mode 100644 index 0000000000..2e6040bd16 --- /dev/null +++ b/extra/spheres/tags.txt @@ -0,0 +1,2 @@ +opengl +glsl From 60025d45c37e6b744852723b4cd5b0709defa394 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 16 Apr 2008 21:06:13 -0700 Subject: [PATCH 018/220] Add environment mapping to spheres demo. Modernize more code in bunny and demo-support --- extra/bunny/outlined/outlined.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 23 ++- extra/spheres/spheres.factor | 151 ++++++++++++------ 3 files changed, 112 insertions(+), 64 deletions(-) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 85202e4185..9c4e8b22a2 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -234,4 +234,4 @@ M: bunny-outlined draw-bunny M: bunny-outlined dispose [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ dispose-framebuffer ] tri + [ dispose-framebuffer ] tri ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 524567b5bd..adc30e6f0f 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,13 +1,10 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces - opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; + opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render accessors ; IN: opengl.demo-support : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline : KEY-ROTATE-STEP 1.0 ; inline -: DIMS { 640 480 } ; inline - -: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ; SYMBOL: last-drag-loc @@ -15,7 +12,7 @@ TUPLE: demo-gadget yaw pitch distance ; : ( yaw pitch distance -- gadget ) demo-gadget construct-gadget - [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ; + [ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ; GENERIC: far-plane ( gadget -- z ) GENERIC: near-plane ( gadget -- z ) @@ -28,6 +25,8 @@ M: demo-gadget near-plane ( gadget -- z ) M: demo-gadget distance-step ( gadget -- dz ) drop 1.0 64.0 / ; +: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; + : yaw-demo-gadget ( yaw gadget -- ) [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; @@ -38,16 +37,16 @@ M: demo-gadget distance-step ( gadget -- dz ) [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; M: demo-gadget pref-dim* ( gadget -- dim ) - drop DIMS ; + drop { 640 480 } ; : -+ ( x -- -x x ) dup neg swap ; : demo-gadget-frustum ( gadget -- -x x -y y near far ) - [ near-plane ] [ far-plane ] bi [ - drop FOV-RATIO swap FOV / v*n + [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ + nip swap FOV / v*n first2 [ -+ ] bi@ - ] 2keep ; + ] 3keep drop ; : demo-gadget-set-matrices ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear @@ -58,9 +57,9 @@ M: demo-gadget pref-dim* ( gadget -- dim ) ] [ GL_MODELVIEW glMatrixMode glLoadIdentity - [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + [ >r 0.0 0.0 r> distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] tri ] bi ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index d8ecb2da98..6f1a7c7508 100644 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers opengl multiline ui.gadgets accessors sequences ui.render ui math -arrays.lib combinators ; +arrays arrays.lib combinators ; IN: spheres STRING: plane-vertex-shader @@ -48,17 +48,15 @@ main() } ; -STRING: sphere-fragment-shader +STRING: sphere-solid-color-fragment-shader uniform vec3 light_position; -varying float vradius; -varying vec3 sphere_position; -varying vec4 world_position, vcolor; +varying vec4 vcolor; -vec4 ambient = vec4(0.3, 0.2, 0.2, 1.0); -vec4 diffuse = vec4(0.7, 0.8, 0.8, 1.0); +const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0); +const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0); vec4 -light(vec3 point, vec3 normal) +sphere_color(vec3 point, vec3 normal) { vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz; vec3 direction = normalize(transformed_light_position - point); @@ -66,6 +64,25 @@ light(vec3 point, vec3 normal) return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a); } +; + +STRING: sphere-texture-fragment-shader +uniform samplerCube surface_texture; + +vec4 +sphere_color(vec3 point, vec3 normal) +{ + vec3 reflect = reflect(normalize(point), normal); + return textureCube(surface_texture, reflect * gl_NormalMatrix); +} +; + +STRING: sphere-main-fragment-shader +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position; + +vec4 sphere_color(vec3 point, vec3 normal); void main() @@ -78,12 +95,12 @@ main() vec4 transformed_surface = gl_ProjectionMatrix * world_surface; gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5; - gl_FragColor = light(world_surface.xyz, surface); + gl_FragColor = sphere_color(world_surface.xyz, surface); } ; TUPLE: spheres-gadget - plane-program sphere-program + plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer reflection-texture ; @@ -98,6 +115,9 @@ M: spheres-gadget far-plane ( gadget -- z ) M: spheres-gadget distance-step ( gadget -- dz ) drop 0.5 ; +: (reflection-dim) ( -- w h ) + 1024 1024 ; + : (make-reflection-texture) ( -- texture ) gen-texture [ GL_TEXTURE_CUBE_MAP swap glBindTexture @@ -109,14 +129,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP_NEGATIVE_X GL_TEXTURE_CUBE_MAP_NEGATIVE_Y GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray - [ 0 GL_RGBA8 1024 1024 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] + [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; : (make-reflection-depthbuffer) ( -- depthbuffer ) gen-renderbuffer [ GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT - GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 1024 1024 glRenderbufferStorageEXT + GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT ] keep ; : (make-reflection-framebuffer) ( depthbuffer -- framebuffer ) @@ -126,11 +146,23 @@ M: spheres-gadget distance-step ( gadget -- dz ) glFramebufferRenderbufferEXT ] with-framebuffer ; +: (plane-program) ( -- program ) + plane-vertex-shader plane-fragment-shader ; +: (solid-sphere-program) ( -- program ) + sphere-vertex-shader check-gl-shader + sphere-solid-color-fragment-shader check-gl-shader + sphere-main-fragment-shader check-gl-shader + 3array check-gl-program ; +: (texture-sphere-program) ( -- program ) + sphere-vertex-shader check-gl-shader + sphere-texture-fragment-shader check-gl-shader + sphere-main-fragment-shader check-gl-shader + 3array check-gl-program ; + M: spheres-gadget graft* ( gadget -- ) - plane-vertex-shader plane-fragment-shader - >>plane-program - sphere-vertex-shader sphere-fragment-shader - >>sphere-program + (plane-program) >>plane-program + (solid-sphere-program) >>solid-sphere-program + (texture-sphere-program) >>texture-sphere-program (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer @@ -141,7 +173,8 @@ M: spheres-gadget ungraft* ( gadget -- ) [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] [ reflection-texture>> [ delete-texture ] when* ] - [ sphere-program>> [ delete-gl-program ] when* ] + [ solid-sphere-program>> [ delete-gl-program ] when* ] + [ texture-sphere-program>> [ delete-gl-program ] when* ] [ plane-program>> [ delete-gl-program ] when* ] } cleave ; @@ -157,15 +190,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; : sphere-scene ( gadget -- ) - GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor - glClear + GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear [ - sphere-program>> dup { + solid-sphere-program>> dup { { "light_position" [ 0.0 0.0 100.0 glUniform3f ] } } [ - [ { 0.0 0.0 0.0 } 4.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] - [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] - [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] tri + { + [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] + [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ] + [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ] + [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ] + } cleave ] with-gl-program ] [ plane-program>> { } [ @@ -187,44 +224,56 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) swap reflection-texture>> >r >r GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT - r> r> 0 glFramebufferTexture2DEXT ; + r> r> 0 glFramebufferTexture2DEXT + check-framebuffer ; -M: spheres-gadget draw-gadget* ( gadget -- ) - GL_DEPTH_TEST glEnable - 0.15 0.15 1.0 1.0 glClearColor { +: (draw-reflection-texture) ( gadget -- ) + dup reflection-framebuffer>> [ { + [ drop 0 0 (reflection-dim) glViewport ] [ GL_PROJECTION glMatrixMode glLoadIdentity reflection-frustum glFrustum GL_MODELVIEW glMatrixMode glLoadIdentity - glPushMatrix - ] - [ - dup reflection-framebuffer>> [ { - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) - glPopMatrix glPushMatrix - 90.0 1.0 0.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) - glPopMatrix - -90.0 1.0 0.0 0.0 glRotatef ] - [ sphere-scene ] - } cleave ] with-framebuffer + 180.0 0.0 0.0 1.0 glRotatef ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef glPushMatrix ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) + glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) + glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + [ dim>> 0 0 rot first2 glViewport ] + } cleave ] with-framebuffer ; + +M: spheres-gadget draw-gadget* ( gadget -- ) + GL_DEPTH_TEST glEnable + GL_SCISSOR_TEST glDisable + 0.15 0.15 1.0 1.0 glClearColor { + [ (draw-reflection-texture) ] [ demo-gadget-set-matrices ] [ sphere-scene ] + [ + { texture-sphere-program>> reflection-texture>> } get-slots + GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit + dup { + { "surface_texture" [ 0 glUniform1i ] } + } [ + { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) + ] with-gl-program + ] } cleave ; : spheres-window ( -- ) From 625d4037feea41d05f3157a277c82db800de5651 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:22:04 -0500 Subject: [PATCH 019/220] Minor tweak to project-euler --- extra/project-euler/150/150.factor | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 5b22a1b9f6..5d83f5a732 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,15 +1,21 @@ ! Copyright (c) 2008 Eric Mertens ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences locals ; +USING: kernel math sequences sequences.private locals hints ; IN: project-euler.150 +PRIVATE> USING: arrays kernel.private ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | m x - [| z | - x z + table nth - [ y z + 1+ swap nth ] - [ y swap nth ] bi - - ] map partial-sums infimum + x z + table nth-unsafe + [ y z + 1+ swap nth-unsafe ] + [ y swap nth-unsafe ] bi - + ] map partial-sum-infimum ] map-infimum ] map-infimum ] ; +HINTS: (euler150) fixnum ; + : euler150 ( -- n ) 1000 (euler150) ; From 390afacac89026ced32dd3052bfe557937b2ef8f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:22:24 -0500 Subject: [PATCH 020/220] Better modular arithmetic optmizer --- core/inference/class/class-tests.factor | 50 +++++++++++++++++- core/math/integers/integers-tests.factor | 7 +++ core/math/math-docs.factor | 12 ++--- core/math/math.factor | 6 ++- core/optimizer/math/math.factor | 56 +++++++++++++++++++-- extra/math/functions/functions-docs.factor | 11 ++-- extra/math/functions/functions-tests.factor | 3 -- extra/math/functions/functions.factor | 3 -- 8 files changed, 125 insertions(+), 23 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 038ab1d230..ac64b53070 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -13,9 +13,10 @@ system layouts vectors ; ! Ensure type inference works as it is supposed to by checking ! if various methods get inlined -: inlined? ( quot word -- ? ) +: inlined? ( quot seq/word -- ? ) + dup word? [ 1array ] when swap dataflow optimize - [ node-param eq? ] with node-exists? not ; + [ node-param swap member? ] with node-exists? not ; GENERIC: mynot ( x -- y ) @@ -323,3 +324,48 @@ cell-bits 32 = [ ] when ] \ + inlined? ] unit-test + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +! [ t ] [ +! [ +! { integer } declare [ 256 mod ] map +! ] { mod fixnum-mod } inlined? +! ] unit-test +! +! [ t ] [ +! [ +! { integer } declare [ 0 >= ] map +! ] { >= fixnum>= } inlined? +! ] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index eebc45511a..fe8e5bddc8 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -184,3 +184,10 @@ unit-test [ HEX: 988a259c3433f237 ] [ B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum ] unit-test + +[ t ] [ 256 power-of-2? ] unit-test +[ f ] [ 123 power-of-2? ] unit-test + +[ f ] [ -128 power-of-2? ] unit-test +[ f ] [ 0 power-of-2? ] unit-test +[ t ] [ 1 power-of-2? ] unit-test diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 5533c00090..c8a763b5f7 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel sequences quotations -math.private math.functions ; +math.private ; IN: math ARTICLE: "division-by-zero" "Division by zero" @@ -26,17 +26,13 @@ $nl { $subsection < } { $subsection <= } { $subsection > } -{ $subsection >= } -"Inexact comparison:" -{ $subsection ~ } ; +{ $subsection >= } ; ARTICLE: "modular-arithmetic" "Modular arithmetic" { $subsection mod } { $subsection rem } { $subsection /mod } { $subsection /i } -{ $subsection mod-inv } -{ $subsection ^mod } { $see-also "integer-functions" } ; ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" @@ -363,6 +359,10 @@ HELP: next-power-of-2 { $values { "m" "a non-negative integer" } { "n" "an integer" } } { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ; +HELP: power-of-2? +{ $values { "n" integer } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; + HELP: each-integer { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." } diff --git a/core/math/math.factor b/core/math/math.factor index 064b488ac3..2b33c8b40b 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -121,7 +121,11 @@ M: float fp-nan? : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable -: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline +: power-of-2? ( n -- ? ) + dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable + +: align ( m w -- n ) + 1- [ + ] keep bitnot bitand ; inline fixnum consumed-by? ; +: coerced-to-fixnum? ( #call -- ? ) + dup dup node-in-d [ node-class integer class< ] with all? + [ \ >fixnum consumed-by? ] [ drop f ] if ; { { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } + { + [ >r >fixnum r> >fixnum fixnum+fast ] } + { - [ >r >fixnum r> >fixnum fixnum-fast ] } + { * [ >r >fixnum r> >fixnum fixnum*fast ] } } [ [ [ dup remove-overflow-check? - over coereced-to-fixnum? or + over coerced-to-fixnum? or ] , [ f splice-quot ] curry , ] { } make 1array define-optimizers @@ -467,3 +471,49 @@ most-negative-fixnum most-positive-fixnum [a,b] [ [ fixnum-shift-fast ] f splice-quot ] } } define-optimizers + +: convert-rem-to-and? ( #call -- ? ) + dup node-in-d { + { [ 2dup first node-class integer class< not ] [ f ] } + { [ 2dup second node-literal integer? not ] [ f ] } + { [ 2dup second node-literal power-of-2? not ] [ f ] } + [ t ] + } cond 2nip ; + +: convert-mod-to-and? ( #call -- ? ) + dup dup node-in-d first node-interval 0 [a,inf] interval-subset? + [ convert-rem-to-and? ] [ drop f ] if ; + +: convert-mod-to-and ( #call -- node ) + dup + dup node-in-d second node-literal 1- + [ nip bitand ] curry f splice-quot ; + +{ mod bignum-mod fixnum-mod } [ + { + { + [ dup convert-mod-to-and? ] + [ convert-mod-to-and ] + } + } define-optimizers +] each + +\ rem { + { + [ dup convert-rem-to-and? ] + [ convert-mod-to-and ] + } +} define-optimizers + +: fixnumify-bitand? ( #call -- ? ) + dup node-in-d second node-interval fixnum fits? ; + +: fixnumify-bitand ( #call -- node ) + [ >r >fixnum r> >fixnum fixnum-bitand ] f splice-quot ; + +\ bitand { + { + [ dup fixnumify-bitand? ] + [ fixnumify-bitand ] + } +} define-optimizers diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor index f0819fb03e..35471653dc 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -7,6 +7,9 @@ ARTICLE: "integer-functions" "Integer functions" { $subsection gcd } { $subsection log2 } { $subsection next-power-of-2 } +"Modular exponentiation:" +{ $subsection ^mod } +{ $subsection mod-inv } "Tests:" { $subsection power-of-2? } { $subsection even? } @@ -33,7 +36,9 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" { $subsection ceiling } { $subsection floor } { $subsection truncate } -{ $subsection round } ; +{ $subsection round } +"Inexact comparison:" +{ $subsection ~ } ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" @@ -107,10 +112,6 @@ HELP: >rect { $values { "z" number } { "x" real } { "y" real } } { $description "Extracts the real and imaginary components of a complex number." } ; -HELP: power-of-2? -{ $values { "n" integer } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; - HELP: align { $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } } { $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." } diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6773678dab..8c71eb545b 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -81,9 +81,6 @@ IN: math.functions.tests [ 1/8 ] [ 2 -3 ^ ] unit-test [ t ] [ 1 100 shift 2 100 ^ = ] unit-test -[ t ] [ 256 power-of-2? ] unit-test -[ f ] [ 123 power-of-2? ] unit-test - [ 1 ] [ 7/8 ceiling ] unit-test [ 2 ] [ 3/2 ceiling ] unit-test [ 0 ] [ -7/8 ceiling ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index b3cfba8650..632939ff71 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -102,9 +102,6 @@ M: real absq sq ; [ ~abs ] } cond ; -: power-of-2? ( n -- ? ) - dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable - : >rect ( z -- x y ) dup real-part swap imaginary-part ; inline : conjugate ( z -- z* ) >rect neg rect> ; inline From 80ee4f8771040cec8de491d71b0839dfbb5f3264 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:54:47 -0500 Subject: [PATCH 021/220] Code cleanup --- core/inference/class/class-tests.factor | 30 +++++++++++++++++-------- core/inference/class/class.factor | 12 ++++------ 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index ac64b53070..a2bd2453f4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -349,6 +349,27 @@ cell-bits 32 = [ ] { mod fixnum-mod } inlined? ] unit-test +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test + +[ t ] [ + [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +! Later + ! [ t ] [ ! [ ! { integer } declare [ 256 mod ] map @@ -360,12 +381,3 @@ cell-bits 32 = [ ! { integer } declare [ 0 >= ] map ! ] { >= fixnum>= } inlined? ! ] unit-test - -[ t ] [ - [ - { integer } declare - dup 0 >= [ - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] [ dup ] if - ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 033d2cce7a..1c0f5a46e1 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -260,18 +260,14 @@ DEFER: (infer-classes) : merge-classes ( nodes node -- ) >r (merge-classes) r> set-classes ; -: (merge-intervals) ( nodes quot -- seq ) - >r - [ node-input-intervals ] map - f pad-all flip - r> map ; inline - : set-intervals ( seq node -- ) node-out-d [ set-value-interval* ] 2reverse-each ; : merge-intervals ( nodes node -- ) - >r [ dup first [ interval-union ] reduce ] - (merge-intervals) r> set-intervals ; + >r + [ node-input-intervals ] map f pad-all flip + [ dup first [ interval-union ] reduce ] map + r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) [ merge-classes ] [ merge-intervals ] 2bi ; From 608a1c03f41483ccfea992ffe8bd041e999fbcb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 14:34:32 -0500 Subject: [PATCH 022/220] Improve type inference for recursive functions --- core/inference/class/class-tests.factor | 19 ++++++++++++ core/optimizer/math/math.factor | 40 ++++--------------------- 2 files changed, 25 insertions(+), 34 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index a2bd2453f4..4d215bf6f5 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -368,6 +368,25 @@ cell-bits 32 = [ ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? ] unit-test +: fib ( m -- n ) + dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline + +[ t ] [ + [ 27.0 fib ] { < - } inlined? +] unit-test + +[ t ] [ + [ 27 fib ] { < - } inlined? +] unit-test + +[ t ] [ + [ 27 >bignum fib ] { < - } inlined? +] unit-test + +[ f ] [ + [ 27/2 fib ] { < - } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 218d5465af..4afb860795 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -10,12 +10,7 @@ classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining generic.standard system ; -{ + bignum+ float+ fixnum+fast } { - { { number 0 } [ drop ] } - { { 0 number } [ nip ] } -} define-identities - -{ fixnum+ } { +{ + bignum+ float+ fixnum+ fixnum+fast } { { { number 0 } [ drop ] } { { 0 number } [ nip ] } } define-identities @@ -41,7 +36,7 @@ generic.standard system ; { { @ @ } [ 2drop t ] } } define-identities -{ * fixnum* bignum* float* } { +{ * fixnum* fixnum*fast bignum* float* } { { { number 1 } [ drop ] } { { 1 number } [ nip ] } { { number 0 } [ nip ] } @@ -89,7 +84,7 @@ generic.standard system ; } define-identities : math-closure ( class -- newclass ) - { fixnum integer rational real } + { fixnum bignum integer rational float real number } [ class< ] with find nip number or ; : fits? ( interval class -- ? ) @@ -354,15 +349,17 @@ most-negative-fixnum most-positive-fixnum [a,b] { + [ fixnum+fast ] } { - [ fixnum-fast ] } { * [ fixnum*fast ] } + { shift [ fixnum-shift-fast ] } { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } + { fixnum-shift [ fixnum-shift-fast ] } ! these are here as an optimization. if they weren't given ! explicitly, the same would be inferred after an extra ! optimization step (see optimistic-inline?) { 1+ [ 1 fixnum+fast ] } { 1- [ 1 fixnum-fast ] } - { 2/ [ -1 fixnum-shift ] } + { 2/ [ -1 fixnum-shift-fast ] } { neg [ 0 swap fixnum-fast ] } } [ [ @@ -447,31 +444,6 @@ most-negative-fixnum most-positive-fixnum [a,b] ] { } make 1array define-optimizers ] assoc-each -: fixnum-shift-fast-pos? ( node -- ? ) - #! Shifting 1 to the left won't overflow if the shift - #! count is small enough - dup dup node-in-d first node-literal 1 = [ - dup node-in-d second node-interval - 0 cell-bits tag-bits get - 2 - [a,b] interval-subset? - ] [ drop f ] if ; - -: fixnum-shift-fast-neg? ( node -- ? ) - #! Shifting any number to the right won't overflow if the - #! shift count is small enough - dup node-in-d second node-interval - cell-bits 1- neg 0 [a,b] interval-subset? ; - -: fixnum-shift-fast? ( node -- ? ) - dup fixnum-shift-fast-pos? - [ drop t ] [ fixnum-shift-fast-neg? ] if ; - -\ fixnum-shift { - { - [ dup fixnum-shift-fast? ] - [ [ fixnum-shift-fast ] f splice-quot ] - } -} define-optimizers - : convert-rem-to-and? ( #call -- ? ) dup node-in-d { { [ 2dup first node-class integer class< not ] [ f ] } From 336e30b054d6d8d6353c5c2a4431d69c7a659c66 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 17 Apr 2008 19:43:07 -0500 Subject: [PATCH 023/220] add interval queries for sqlite --- extra/db/db.factor | 4 +- extra/db/sql/sql-tests.factor | 2 +- extra/db/sql/sql.factor | 11 +++-- extra/db/sqlite/lib/lib.factor | 5 ++- extra/db/sqlite/sqlite.factor | 68 ++++++++++++++++++++++------- extra/db/tuples/tuples-tests.factor | 41 ++++++++++++++--- extra/db/types/types.factor | 2 + 7 files changed, 103 insertions(+), 30 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index baf4e9db5a..533f238f04 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,7 +11,7 @@ TUPLE: db update-statements delete-statements ; -: construct-db ( class -- obj ) +: new-db ( class -- obj ) new H{ } clone >>insert-statements H{ } clone >>update-statements @@ -20,7 +20,7 @@ TUPLE: db GENERIC: make-db* ( seq class -- db ) : make-db ( seq class -- db ) - construct-db make-db* ; + new-db make-db* ; GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index db69d71a84..cab7b83ced 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -1,7 +1,7 @@ USING: kernel namespaces db.sql sequences math ; IN: db.sql.tests -TUPLE: person name age ; +! TUPLE: person name age ; : insert-1 { insert { table "person" } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index b0ec7aaf34..d7ef986ea6 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -55,15 +55,18 @@ TUPLE: no-sql-match ; { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } + { [ dup quotation? ] [ call ] } [ T{ no-sql-match } throw ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) [ unclip { - { insert [ "insert into" sql% ] } - { update [ "update" sql% ] } - { delete [ "delete" sql% ] } - { select [ "select" sql% ] } + { \ create [ "create table" sql% ] } + { \ drop [ "drop table" sql% ] } + { \ insert [ "insert into" sql% ] } + { \ update [ "update" sql% ] } + { \ delete [ "delete" sql% ] } + { \ select [ "select" sql% ] } } case [ sql% ] each ] { "" { } { } { } { } } nmake ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e66accd7e9..b6221e5a1e 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -tools.walker ; +tools.walker io.backend ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -23,7 +23,8 @@ IN: db.sqlite.lib [ sqlite-error ] } cond ; -: sqlite-open ( filename -- db ) +: sqlite-open ( path -- db ) + normalize-path "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 11c0150cd2..02bf314a0a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,8 +4,9 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators +words combinators.lib db.types combinators math.intervals io namespaces.lib accessors ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -54,16 +55,20 @@ M: sqlite-statement bind-statement* ( statement -- ) [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; +GENERIC: sqlite-bind-conversion ( tuple obj -- array ) + +M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri 3array ; + +M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) + nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; + M: sqlite-statement bind-tuple ( tuple statement -- ) [ - in-params>> - [ - [ column-name>> ":" prepend ] - [ slot-name>> rot get-slot-named ] - [ type>> ] tri 3array - ] with map - ] keep - bind-statement ; + in-params>> [ sqlite-bind-conversion ] with map + ] keep bind-statement ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid @@ -129,13 +134,46 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db ( tuple -- statement ) ; +M: sqlite-db bind% ( spec -- ) + dup 1, column-name>> ":" prepend 0% ; + : where-primary-key% ( specs -- ) " where " 0% find-primary-key dup column-name>> 0% " = " 0% bind% ; -: where-clause ( specs -- ) - " where " 0% - [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; +! : where-object ( tuple specs -- ) + ! [ dup column-name>> get-slot-named ] keep + ! dup column-name>> 0% " = " 0% bind% ; + +GENERIC: where-object ( specs obj -- ) + +: interval-comparison ( ? str -- str ) + "from" = " >" " <" ? swap [ "= " append ] when ; + +: where-interval ( spec val ? from/to -- ) + roll [ + column-name>> + [ 0% interval-comparison 0% ] + [ ":" spin 3append dup 0% ] 2bi + swap + ] [ + type>> + ] bi literal-bind boa 1, ; + +M: interval where-object ( specs obj -- ) + [ from>> first2 "from" where-interval " and " 0% ] + [ to>> first2 "to" where-interval ] 2bi ; + +M: object where-object ( specs obj -- ) + drop + dup column-name>> 0% " = " 0% bind% ; + +: where-clause ( tuple specs -- ) + " where " 0% [ + " and " 0% + ] [ + 2dup slot-name>> swap get-slot-named where-object + ] interleave drop ; M: sqlite-db ( class -- statement ) [ @@ -158,9 +196,6 @@ M: sqlite-db ( specs table -- sql ) ! : select-interval ( interval name -- ) ; ! : select-sequence ( seq name -- ) ; -M: sqlite-db bind% ( spec -- ) - dup 1, column-name>> ":" prepend 0% ; - M: sqlite-db ( tuple class -- statement ) [ "select " 0% @@ -168,8 +203,9 @@ M: sqlite-db ( tuple class -- statement ) [ dup column-name>> 0% 2, ] interleave " from " 0% 0% + dupd [ slot-name>> swap get-slot-named ] with subset - dup empty? [ drop ] [ where-clause ] if ";" 0% + dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 951ded32ea..36a8d4cd3f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -233,12 +233,43 @@ TUPLE: exam id name score ; [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test [ - T{ exam f 3 "Kenny" 60 } - T{ exam f 4 "Cartman" 41 } - ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test - ; + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples + ] unit-test -! [ test-ranges ] test-sqlite + [ + { } + ] [ + T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test ; + +[ test-ranges ] test-sqlite TUPLE: secret n message ; C: secret diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 98bc451a6f..bea81f422b 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,6 +15,8 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: literal-bind key value type ; + SINGLETON: +native-id+ SINGLETON: +assigned-id+ SINGLETON: +random-id+ From a8d0eecd9e34b005aac5c540e028e14c62523657 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 21:26:37 -0500 Subject: [PATCH 024/220] Add DLLEXPORT --- vm/ffi_test.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/vm/ffi_test.h b/vm/ffi_test.h index aac5d32f93..2edebd96f1 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -61,3 +61,5 @@ DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); struct test_struct_12 { int a; double x; }; DLLEXPORT double ffi_test_36(struct test_struct_12 x); + +DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); From afaab57f8356b77e7dd9547ecf46bd6e8f8ac638 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 12:43:21 -0500 Subject: [PATCH 025/220] interval, range queries in sqlite --- extra/db/sqlite/sqlite.factor | 62 +++++++++++++++++------------ extra/db/tuples/tuples-tests.factor | 28 +++++++++++-- extra/db/tuples/tuples.factor | 3 ++ extra/db/types/types.factor | 4 +- 4 files changed, 67 insertions(+), 30 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 02bf314a0a..de5c245517 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors ; +io namespaces.lib accessors vectors math.ranges ; USE: tools.walker IN: db.sqlite @@ -104,7 +104,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> - { "" { } { } } nmake ; inline + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake + ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -134,6 +135,12 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db ( tuple -- statement ) ; +M: sqlite-db bind# ( spec obj -- ) + >r + [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ type>> ] bi + r> 1, ; + M: sqlite-db bind% ( spec -- ) dup 1, column-name>> ":" prepend 0% ; @@ -141,38 +148,44 @@ M: sqlite-db bind% ( spec -- ) " where " 0% find-primary-key dup column-name>> 0% " = " 0% bind% ; -! : where-object ( tuple specs -- ) - ! [ dup column-name>> get-slot-named ] keep - ! dup column-name>> 0% " = " 0% bind% ; - -GENERIC: where-object ( specs obj -- ) +GENERIC: where ( specs obj -- ) : interval-comparison ( ? str -- str ) "from" = " >" " <" ? swap [ "= " append ] when ; -: where-interval ( spec val ? from/to -- ) - roll [ - column-name>> - [ 0% interval-comparison 0% ] - [ ":" spin 3append dup 0% ] 2bi - swap - ] [ - type>> - ] bi literal-bind boa 1, ; +: where-interval ( spec obj from/to -- ) + pick column-name>> 0% + >r first2 r> interval-comparison 0% + bind# ; -M: interval where-object ( specs obj -- ) - [ from>> first2 "from" where-interval " and " 0% ] - [ to>> first2 "to" where-interval ] 2bi ; +: in-parens ( quot -- ) + "(" 0% call ")" 0% ; inline -M: object where-object ( specs obj -- ) - drop - dup column-name>> 0% " = " 0% bind% ; +M: interval where ( spec obj -- ) + [ + [ from>> "from" where-interval " and " 0% ] + [ to>> "to" where-interval ] 2bi + ] in-parens ; + +M: sequence where ( spec obj -- ) + [ + [ " or " 0% ] [ dupd where ] interleave drop + ] in-parens ; + +: object-where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + +M: object where ( spec obj -- ) object-where ; + +M: integer where ( spec obj -- ) object-where ; + +M: string where ( spec obj -- ) object-where ; : where-clause ( tuple specs -- ) " where " 0% [ " and " 0% ] [ - 2dup slot-name>> swap get-slot-named where-object + 2dup slot-name>> swap get-slot-named where ] interleave drop ; M: sqlite-db ( class -- statement ) @@ -193,9 +206,6 @@ M: sqlite-db ( specs table -- sql ) dup column-name>> 0% " = " 0% bind% ] sqlite-make ; -! : select-interval ( interval name -- ) ; -! : select-sequence ( seq name -- ) ; - M: sqlite-db ( tuple class -- statement ) [ "select " 0% diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 36a8d4cd3f..691cc6f687 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces math +db.types continuations namespaces math math.ranges prettyprint tools.walker db.sqlite calendar math.intervals db.postgresql ; IN: db.tuples.tests @@ -217,7 +217,7 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; -: test-ranges ( -- ) +: test-intervals ( -- ) exam "EXAM" { { "id" "ID" +native-id+ } @@ -267,9 +267,31 @@ TUPLE: exam id name score ; } ] [ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + } + ] [ + T{ exam f f { "Stan" "Kyle" } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ range f 1 3 1 } } select-tuples ] unit-test ; -[ test-ranges ] test-sqlite +[ test-intervals ] test-sqlite + +: test-ranges + ; TUPLE: secret n message ; C: secret diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 311f18daa9..32431b4ddc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -22,6 +22,9 @@ IN: db.tuples class db-columns find-primary-key sql-spec-slot-name ] keep set-slot-named ; +SYMBOL: sql-counter +: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ; + ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index bea81f422b..9959e894a7 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,7 +15,8 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -TUPLE: literal-bind key value type ; +TUPLE: literal-bind key type value ; +C: literal-bind SINGLETON: +native-id+ SINGLETON: +assigned-id+ @@ -132,6 +133,7 @@ TUPLE: no-sql-modifier ; dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) +HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) class "slots" word-prop slot-named slot-spec-offset ; From 1b836450979c8422d682e609f3541930402dc36a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 13:42:56 -0500 Subject: [PATCH 026/220] error check run process related words in docs use ERROR: --- extra/editors/vim/vim.factor | 2 +- extra/io/launcher/launcher-docs.factor | 3 +++ extra/io/launcher/launcher.factor | 5 +---- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 8d60942d67..f632a478be 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -18,7 +18,7 @@ M: vim vim-command ( file line -- array ) : vim-location ( file line -- ) vim-command vim-detach get-global - [ run-detached ] [ run-process ] if drop ; + [ try-detached ] [ try-process ] if ; "vim" vim-path set-global [ vim-location ] edit-hook set-global diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4446b82f20..dadb627fc0 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -113,6 +113,8 @@ HELP: try-process { $values { "desc" "a launch descriptor" } } { $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; +{ run-process try-process run-detached } related-words + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -171,6 +173,7 @@ ARTICLE: "io.launcher.launch" "Launching processes" "Launching processes:" { $subsection run-process } { $subsection try-process } +{ $subsection run-detached } "Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9b480d0cc2..6ee8660528 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -127,10 +127,7 @@ HOOK: run-process* io-backend ( process -- handle ) run-detached dup detached>> [ dup wait-for-process drop ] unless ; -TUPLE: process-failed code ; - -: process-failed ( code -- * ) - \ process-failed boa throw ; +ERROR: process-failed code ; : try-process ( desc -- ) run-process wait-for-process dup zero? From 8635a0ee2fe52ea0c1455d844a2d79a9611e2d1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 14:02:11 -0500 Subject: [PATCH 027/220] vim should work again --- extra/editors/vim/vim.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index f632a478be..9ce256868b 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -1,5 +1,5 @@ USING: definitions io io.launcher kernel math math.parser -namespaces parser prettyprint sequences editors ; +namespaces parser prettyprint sequences editors accessors ; IN: editors.vim SYMBOL: vim-path @@ -17,8 +17,9 @@ M: vim vim-command ( file line -- array ) : vim-location ( file line -- ) vim-command - vim-detach get-global - [ try-detached ] [ try-process ] if ; + swap >>command + vim-detach get-global [ t >>detached ] when + try-process ; "vim" vim-path set-global [ vim-location ] edit-hook set-global From 6044cc4b3905a7c4b9a30a241f7c31e8032949b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 16:01:31 -0500 Subject: [PATCH 028/220] make throwable, nonthrowable, retryable a type --- extra/db/db.factor | 60 +++++++++++++++++++-------- extra/db/postgresql/postgresql.factor | 2 +- extra/db/sqlite/sqlite.factor | 8 ++-- extra/db/tuples/tuples-tests.factor | 16 ++++--- 4 files changed, 55 insertions(+), 31 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 533f238f04..7a28dea558 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors ; +tools.walker accessors combinators.lib ; IN: db TUPLE: db @@ -36,26 +36,47 @@ HOOK: db-close db ( handle -- ) ] with-variable ; ! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? ; +TUPLE: statement handle sql in-params out-params bind-params bound? type quot ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -TUPLE: nonthrowable-statement < statement ; -TUPLE: throwable-statement < statement ; + +SINGLETON: throwable +SINGLETON: nonthrowable +SINGLETON: retryable + +: make-throwable ( obj -- obj' ) + dup sequence? [ + [ make-throwable ] map + ] [ + throwable >>type + ] if ; : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map ] [ - nonthrowable-statement construct-delegate + nonthrowable >>type ] if ; +: make-retryable ( obj quot -- obj' ) + over sequence? [ + [ make-retryable ] curry map + ] [ + >>quot + retryable >>type + ] if ; + +: handle-random-id ( statement -- ) + drop ; + TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql ; + swap >>sql + throwable >>type ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -70,20 +91,25 @@ GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -GENERIC: execute-statement ( statement -- ) +GENERIC: execute-statement* ( statement type -- ) -M: throwable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ - query-results dispose - ] if ; +M: throwable execute-statement* ( statement type -- ) + drop query-results dispose ; -M: nonthrowable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ +M: nonthrowable execute-statement* ( statement type -- ) + drop [ query-results dispose ] [ 2drop ] recover ; + +M: retryable execute-statement* ( statement type -- ) + [ + dup dup quot>> call [ query-results dispose ] [ 2drop ] recover + ] curry 10 retry ; + +: execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + dup type>> execute-statement* ] if ; : bind-statement ( obj statement -- ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 322143e7a2..9dfa123952 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -11,7 +11,7 @@ IN: db.postgresql TUPLE: postgresql-db < db host port pgopts pgtty db user pass ; -TUPLE: postgresql-statement < throwable-statement ; +TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index de5c245517..e2ea28fe9a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -20,7 +20,7 @@ M: sqlite-db db-open ( db -- db ) M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; -TUPLE: sqlite-statement < throwable-statement ; +TUPLE: sqlite-statement < statement ; TUPLE: sqlite-result-set < result-set has-more? ; @@ -105,7 +105,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - ; inline + + dup handle-random-id ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -223,7 +224,6 @@ M: sqlite-db modifier-table ( -- hashtable ) { +native-id+ "primary key" } { +assigned-id+ "primary key" } { +random-id+ "primary key" } - ! { +nonnative-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -236,7 +236,7 @@ M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; M: sqlite-db compound-type ( str seq -- str' ) over { { "default" [ first number>string join-space ] } - [ 2drop ] ! "no sqlite compound data type" 3array throw ] + [ 2drop ] } case ; M: sqlite-db type-table ( -- assoc ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 691cc6f687..56e401d5ec 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -308,15 +308,13 @@ C: secret [ ] [ T{ secret } select-tuples ] unit-test ; - - -! [ test-random-id ] test-sqlite - [ native-person-schema test-tuples ] test-sqlite - [ assigned-person-schema test-tuples ] test-sqlite - [ assigned-person-schema test-repeated-insert ] test-sqlite - [ native-person-schema test-tuples ] test-postgresql - [ assigned-person-schema test-tuples ] test-postgresql - [ assigned-person-schema test-repeated-insert ] test-postgresql +[ test-random-id ] test-sqlite +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-repeated-insert ] test-sqlite +[ native-person-schema test-tuples ] test-postgresql +[ assigned-person-schema test-tuples ] test-postgresql +[ assigned-person-schema test-repeated-insert ] test-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer From 2d2b3ec9043a9e956bd9fc6a16c37aa39bf584f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 18 Apr 2008 16:51:09 -0500 Subject: [PATCH 029/220] Partial dispatch on integer operations --- core/generic/generic.factor | 3 + core/inference/class/class-tests.factor | 139 ++++++++++-- core/math/intervals/intervals.factor | 2 + core/math/math.factor | 18 +- core/optimizer/inlining/inlining-tests.factor | 10 + core/optimizer/inlining/inlining.factor | 37 ++-- core/optimizer/known-words/known-words.factor | 12 +- core/optimizer/math/math.factor | 204 +++++++----------- .../math/partial/partial-tests.factor | 13 ++ core/optimizer/math/partial/partial.factor | 172 +++++++++++++++ 10 files changed, 433 insertions(+), 177 deletions(-) create mode 100644 core/optimizer/inlining/inlining-tests.factor create mode 100644 core/optimizer/math/partial/partial-tests.factor create mode 100644 core/optimizer/math/partial/partial.factor diff --git a/core/generic/generic.factor b/core/generic/generic.factor index caae16e8ed..6c59d76d07 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -29,6 +29,9 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: specific-method ( class word -- class ) + order min-class ; + GENERIC: effective-method ( ... generic -- method ) : next-method-class ( class generic -- class/f ) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 4d215bf6f5..dcd83f7f7c 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts vectors ; +system layouts vectors optimizer.math.partial ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -18,6 +18,11 @@ system layouts vectors ; swap dataflow optimize [ node-param swap member? ] with node-exists? not ; +[ f ] [ + [ { integer } declare >fixnum ] + \ >fixnum inlined? +] unit-test + GENERIC: mynot ( x -- y ) M: f mynot drop t ; @@ -110,12 +115,17 @@ M: object xyz ; [ { fixnum } declare [ ] times ] \ fixnum+ inlined? ] unit-test -[ f ] [ +[ t ] [ [ { integer fixnum } declare dupd < [ 1 + ] when ] \ + inlined? ] unit-test -[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test +[ f ] [ + [ { integer fixnum } declare dupd < [ 1 + ] when ] + \ +-integer-fixnum inlined? +] unit-test + +[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test [ f ] [ [ @@ -138,13 +148,13 @@ M: object xyz ; DEFER: blah -[ t ] [ +[ ] [ [ \ blah [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit - \ blah compiled? + \ blah word-def dataflow optimize drop ] unit-test GENERIC: detect-fx ( n -- n ) @@ -159,14 +169,20 @@ M: fixnum detect-fx ; ] \ detect-fx inlined? ] unit-test +[ t ] [ + [ + 1000000000000000000000000000000000 [ ] times + ] \ + inlined? +] unit-test [ f ] [ [ 1000000000000000000000000000000000 [ ] times - ] \ 1+ inlined? + ] \ +-integer-fixnum inlined? ] unit-test [ f ] [ - [ { bignum } declare [ ] times ] \ 1+ inlined? + [ { bignum } declare [ ] times ] + \ +-integer-fixnum inlined? ] unit-test @@ -359,15 +375,6 @@ cell-bits 32 = [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test -[ t ] [ - [ - { integer } declare - dup 0 >= [ - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] [ dup ] if - ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test - : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline @@ -387,6 +394,106 @@ cell-bits 32 = [ [ 27/2 fib ] { < - } inlined? ] unit-test +[ t ] [ + [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ] + \ fixnum-bitand inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare length [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 0 [ + ] reduce ] + { < <-integer-fixnum } inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 0 [ + ] reduce ] + \ +-integer-fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] { >fixnum } inlined? +] unit-test + +[ f ] [ + [ + { integer } declare [ ] map + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare 1 + { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 4ca1a8637c..77d60e67f8 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -96,6 +96,8 @@ C: interval : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ; +: interval-sq ( i1 -- i2 ) dup interval* ; + : make-interval ( from to -- int ) over first over first { { [ 2dup > ] [ 2drop 2drop f ] } diff --git a/core/math/math.factor b/core/math/math.factor index 2b33c8b40b..6a56baea3a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable M: object zero? drop f ; -: 1+ ( x -- y ) 1 + ; foldable -: 1- ( x -- y ) 1 - ; foldable -: 2/ ( x -- y ) -1 shift ; foldable -: sq ( x -- y ) dup * ; foldable -: neg ( x -- -x ) 0 swap - ; foldable -: recip ( x -- y ) 1 swap / ; foldable +: 1+ ( x -- y ) 1 + ; inline +: 1- ( x -- y ) 1 - ; inline +: 2/ ( x -- y ) -1 shift ; inline +: sq ( x -- y ) dup * ; inline +: neg ( x -- -x ) 0 swap - ; inline +: recip ( x -- y ) 1 swap / ; inline : ?1+ [ 1+ ] [ 0 ] if* ; inline : /f ( x y -- z ) >r >float r> >float float/f ; inline -: max ( x y -- z ) [ > ] most ; foldable -: min ( x y -- z ) [ < ] most ; foldable +: max ( x y -- z ) [ > ] most ; inline +: min ( x y -- z ) [ < ] most ; inline : between? ( x y z -- ? ) pick >= [ >= ] [ 2drop f ] if ; inline : rem ( x y -- z ) tuck mod over + swap mod ; foldable -: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable +: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline : [-] ( x y -- z ) - 0 max ; inline diff --git a/core/optimizer/inlining/inlining-tests.factor b/core/optimizer/inlining/inlining-tests.factor new file mode 100644 index 0000000000..608054becb --- /dev/null +++ b/core/optimizer/inlining/inlining-tests.factor @@ -0,0 +1,10 @@ +IN: optimizer.inlining.tests +USING: tools.test optimizer.inlining ; + +\ word-flat-length must-infer + +\ inlining-math-method must-infer + +\ optimistic-inline? must-infer + +\ find-identity must-infer diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 8447d1be5f..e74e8b1de2 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -3,10 +3,11 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math continuations -optimizer.def-use optimizer.backend generic.standard -optimizer.specializers optimizer.def-use optimizer.pattern-match -generic.standard optimizer.control kernel.private ; +combinators classes classes.algebra generic.math +optimizer.math.partial continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -53,8 +54,6 @@ DEFER: (flat-length) [ word-def (flat-length) ] with-scope ; ! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - : node-class# ( node n -- class ) over node-in-d ?nth node-class ; @@ -79,21 +78,31 @@ DEFER: (flat-length) object } [ class< ] with find nip ; -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes +: inlining-math-method ( #call word -- quot/f ) + swap node-input-classes [ first normalize-math-class ] [ second normalize-math-class ] bi - 3dup math-both-known? - [ math-method f splice-quot ] - [ 2drop 2drop t ] if ; + 3dup math-both-known? [ math-method* ] [ 3drop f ] if ; + +: inline-math-method ( #call word -- node/t ) + [ drop ] [ inlining-math-method ] 2bi + dup [ f splice-quot ] [ 2drop t ] if ; + +: inline-math-partial ( #call word -- node/t ) + [ drop ] + [ + "derived-from" word-prop first + inlining-math-method dup + ] + [ nip 1quotation ] 2tri + [ = not ] [ drop ] 2bi and + [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } + { [ dup math-partial? ] [ inline-math-partial ] } [ 2drop t ] } cond ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index cf71af216e..91d0c1c0de 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -83,21 +83,11 @@ sequences.private combinators ; ] "constraints" set-word-prop ! eq? on the same object is always t -{ eq? bignum= float= number= = } { +{ eq? = } { { { @ @ } [ 2drop t ] } } define-identities ! Specializers -{ 1+ 1- sq neg recip sgn } [ - { number } "specializer" set-word-prop -] each - -\ 2/ { fixnum } "specializer" set-word-prop - -{ min max } [ - { number number } "specializer" set-word-prop -] each - { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 4afb860795..fe33c57d42 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -8,80 +8,91 @@ namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining -generic.standard system ; +optimizer.math.partial generic.standard system ; -{ + bignum+ float+ fixnum+ fixnum+fast } { +: define-math-identities ( word identities -- ) + >r all-derived-ops r> define-identities ; + +\ number= { + { { @ @ } [ 2drop t ] } +} define-math-identities + +\ + { { { number 0 } [ drop ] } { { 0 number } [ nip ] } -} define-identities +} define-math-identities -{ - fixnum- bignum- float- fixnum-fast } { +\ - { { { number 0 } [ drop ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ < fixnum< bignum< float< } { +\ < { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ <= fixnum<= bignum<= float<= } { +\ <= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ > fixnum> bignum> float>= } { +\ > { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ >= fixnum>= bignum>= float>= } { +\ >= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ * fixnum* fixnum*fast bignum* float* } { +\ * { { { number 1 } [ drop ] } { { 1 number } [ nip ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } { { number -1 } [ drop 0 swap - ] } { { -1 number } [ nip 0 swap - ] } -} define-identities +} define-math-identities -{ / fixnum/i bignum/i float/f } { +\ / { { { number 1 } [ drop ] } { { number -1 } [ drop 0 swap - ] } -} define-identities +} define-math-identities -{ fixnum-mod bignum-mod } { - { { number 1 } [ 2drop 0 ] } -} define-identities +\ mod { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities -{ bitand fixnum-bitand bignum-bitand } { +\ rem { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities + +\ bitand { { { number -1 } [ drop ] } { { -1 number } [ nip ] } { { @ @ } [ drop ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } -} define-identities +} define-math-identities -{ bitor fixnum-bitor bignum-bitor } { +\ bitor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { @ @ } [ drop ] } { { number -1 } [ nip ] } { { -1 number } [ drop ] } -} define-identities +} define-math-identities -{ bitxor fixnum-bitxor bignum-bitxor } { +\ bitxor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { number -1 } [ drop bitnot ] } { { -1 number } [ nip bitnot ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ shift fixnum-shift fixnum-shift-fast bignum-shift } { +\ shift { { { 0 number } [ drop ] } { { number 0 } [ drop ] } -} define-identities +} define-math-identities : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number } @@ -126,15 +137,9 @@ generic.standard system ; r> post-process ; inline { - { 1+ integer interval-1+ } - { 1- integer interval-1- } - { neg integer interval-neg } - { shift integer interval-recip } { bitnot fixnum interval-bitnot } { fixnum-bitnot f interval-bitnot } { bignum-bitnot f interval-bitnot } - { 2/ fixnum interval-2/ } - { sq integer f } } [ first3 [ math-output-class/interval-1 @@ -164,35 +169,16 @@ generic.standard system ; { * integer interval* } { / rational interval/ } { /i integer interval/i } - - { fixnum+ f interval+ } - { fixnum+fast f interval+ } - { fixnum- f interval- } - { fixnum-fast f interval- } - { fixnum* f interval* } - { fixnum*fast f interval* } - { fixnum/i f interval/i } - - { bignum+ f interval+ } - { bignum- f interval- } - { bignum* f interval* } - { bignum/i f interval/i } - { bignum-shift f interval-shift-safe } - - { float+ f interval+ } - { float- f interval- } - { float* f interval* } - { float/f f interval/ } - - { min fixnum interval-min } - { max fixnum interval-max } + { shift f interval-shift-safe } } [ first3 [ - math-output-class/interval-2 - ] 2curry "output-classes" set-word-prop + [ + math-output-class/interval-2 + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each -{ fixnum-shift fixnum-shift-fast shift } [ +\ shift [ [ dup node-in-d second value-interval* @@ -200,7 +186,7 @@ generic.standard system ; \ interval-shift-safe math-output-class/interval-2 ] "output-classes" set-word-prop -] each +] each-derived-op : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -231,21 +217,17 @@ generic.standard system ; { { mod fixnum mod-range } - { fixnum-mod f mod-range } - { bignum-mod f mod-range } - { float-mod f mod-range } - { rem integer rem-range } { bitand fixnum bitand-range } - { fixnum-bitand f bitand-range } - { bitor fixnum f } { bitxor fixnum f } } [ first3 [ - math-output-class/interval-special - ] 2curry "output-classes" set-word-prop + [ + math-output-class/interval-special + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each : twiddle-interval ( i1 -- i2 ) @@ -275,26 +257,12 @@ generic.standard system ; { <= assume<= assume> } { > assume> assume<= } { >= assume>= assume< } - - { fixnum< assume< assume>= } - { fixnum<= assume<= assume> } - { fixnum> assume> assume<= } - { fixnum>= assume>= assume< } - - { bignum< assume< assume>= } - { bignum<= assume<= assume> } - { bignum> assume> assume<= } - { bignum>= assume>= assume< } - - { float< assume< assume>= } - { float<= assume<= assume> } - { float> assume> assume<= } - { float>= assume>= assume< } } [ - first3 - [ - [ comparison-constraints ] with-scope - ] 2curry "constraints" set-word-prop + first3 [ + [ + [ comparison-constraints ] with-scope + ] 2curry "constraints" set-word-prop + ] 2curry each-derived-op ] each { @@ -347,20 +315,15 @@ most-negative-fixnum most-positive-fixnum [a,b] { { + [ fixnum+fast ] } + { +-integer-fixnum [ fixnum+fast ] } { - [ fixnum-fast ] } { * [ fixnum*fast ] } + { *-integer-fixnum [ fixnum*fast ] } { shift [ fixnum-shift-fast ] } { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } { fixnum-shift [ fixnum-shift-fast ] } - ! these are here as an optimization. if they weren't given - ! explicitly, the same would be inferred after an extra - ! optimization step (see optimistic-inline?) - { 1+ [ 1 fixnum+fast ] } - { 1- [ 1 fixnum-fast ] } - { 2/ [ -1 fixnum-shift-fast ] } - { neg [ 0 swap fixnum-fast ] } } [ [ [ dup remove-overflow-check? ] , @@ -394,26 +357,13 @@ most-negative-fixnum most-positive-fixnum [a,b] { <= interval<= } { > interval> } { >= interval>= } - - { fixnum< interval< } - { fixnum<= interval<= } - { fixnum> interval> } - { fixnum>= interval>= } - - { bignum< interval< } - { bignum<= interval<= } - { bignum> interval> } - { bignum>= interval>= } - - { float< interval< } - { float<= interval<= } - { float> interval> } - { float>= interval>= } } [ [ - dup [ dupd foldable-comparison? ] curry , - [ fold-comparison ] curry , - ] { } make 1array define-optimizers + [ + dup [ dupd foldable-comparison? ] curry , + [ fold-comparison ] curry , + ] { } make 1array define-optimizers + ] curry each-derived-op ] assoc-each ! The following words are handled in a similar way except if @@ -428,20 +378,20 @@ most-negative-fixnum most-positive-fixnum [a,b] [ \ >fixnum consumed-by? ] [ drop f ] if ; { - { fixnum+ [ fixnum+fast ] } - { fixnum- [ fixnum-fast ] } - { fixnum* [ fixnum*fast ] } - { + [ >r >fixnum r> >fixnum fixnum+fast ] } - { - [ >r >fixnum r> >fixnum fixnum-fast ] } - { * [ >r >fixnum r> >fixnum fixnum*fast ] } + { + [ [ >fixnum ] bi@ fixnum+fast ] } + { - [ [ >fixnum ] bi@ fixnum-fast ] } + { * [ [ >fixnum ] bi@ fixnum*fast ] } + { shift [ [ >fixnum ] bi@ fixnum-shift-fast ] } } [ - [ + >r derived-ops r> [ [ - dup remove-overflow-check? - over coerced-to-fixnum? or - ] , - [ f splice-quot ] curry , - ] { } make 1array define-optimizers + [ + dup remove-overflow-check? + over coerced-to-fixnum? or + ] , + [ f splice-quot ] curry , + ] { } make 1array define-optimizers + ] curry each ] assoc-each : convert-rem-to-and? ( #call -- ? ) @@ -461,14 +411,14 @@ most-negative-fixnum most-positive-fixnum [a,b] dup node-in-d second node-literal 1- [ nip bitand ] curry f splice-quot ; -{ mod bignum-mod fixnum-mod } [ +\ mod [ { { [ dup convert-mod-to-and? ] [ convert-mod-to-and ] } } define-optimizers -] each +] each-derived-op \ rem { { @@ -481,7 +431,7 @@ most-negative-fixnum most-positive-fixnum [a,b] dup node-in-d second node-interval fixnum fits? ; : fixnumify-bitand ( #call -- node ) - [ >r >fixnum r> >fixnum fixnum-bitand ] f splice-quot ; + [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ; \ bitand { { diff --git a/core/optimizer/math/partial/partial-tests.factor b/core/optimizer/math/partial/partial-tests.factor new file mode 100644 index 0000000000..671933b682 --- /dev/null +++ b/core/optimizer/math/partial/partial-tests.factor @@ -0,0 +1,13 @@ +IN: optimizer.math.partial.tests +USING: optimizer.math.partial tools.test math kernel +sequences ; + +[ t ] [ \ + integer fixnum math-both-known? ] unit-test +[ t ] [ \ + bignum fixnum math-both-known? ] unit-test +[ t ] [ \ + integer bignum math-both-known? ] unit-test +[ t ] [ \ + float fixnum math-both-known? ] unit-test +[ f ] [ \ + real fixnum math-both-known? ] unit-test +[ f ] [ \ + object number math-both-known? ] unit-test +[ f ] [ \ number= fixnum object math-both-known? ] unit-test +[ t ] [ \ number= integer fixnum math-both-known? ] unit-test +[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor new file mode 100644 index 0000000000..bbe1d0a83f --- /dev/null +++ b/core/optimizer/math/partial/partial.factor @@ -0,0 +1,172 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel kernel.private math math.private words +sequences parser namespaces assocs quotations arrays +generic generic.math hashtables effects ; +IN: optimizer.math.partial + +! Partial dispatch. + +! This code will be overhauled and generalized when +! multi-methods go into the core. +PREDICATE: math-partial < word + "derived-from" word-prop >boolean ; + +: fixnum-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + drop execute + ] [ + >r drop >r fixnum>bignum r> r> execute + ] if ; inline + +: integer-fixnum-op ( a b fix-word big-word -- c ) + >r pick tag 0 eq? [ + r> drop execute + ] [ + drop fixnum>bignum r> execute + ] if ; inline + +: integer-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + integer-fixnum-op + ] [ + >r drop over tag 0 eq? [ + >r fixnum>bignum r> r> execute + ] [ + r> execute + ] if + ] if ; inline + +<< +: integer-op-combinator ( triple -- word ) + [ + [ second word-name % "-" % ] + [ third word-name % "-op" % ] + bi + ] "" make in get lookup ; + +: integer-op-word ( triple fix-word big-word -- word ) + [ + drop + word-name "fast" tail? >r + [ "-" % ] [ word-name % ] interleave + r> [ "-fast" % ] when + ] "" make in get create ; + +: integer-op-quot ( word fix-word big-word -- quot ) + rot integer-op-combinator 1quotation 2curry ; + +: define-integer-op-word ( word fix-word big-word -- ) + [ + [ integer-op-word ] [ integer-op-quot ] 3bi + 2 1 define-declared + ] + [ + [ integer-op-word ] [ 2drop ] 3bi + "derived-from" set-word-prop + ] 3bi ; + +: define-integer-op-words ( words fix-word big-word -- ) + [ define-integer-op-word ] 2curry each ; + +: integer-op-triples ( word -- triples ) + { + { fixnum integer } + { integer fixnum } + { integer integer } + } swap [ prefix ] curry map ; + +: define-integer-ops ( word fix-word big-word -- ) + >r >r integer-op-triples r> r> + [ define-integer-op-words ] + [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] + 3bi ; + +: define-math-ops ( op -- ) + { fixnum bignum float } + [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc + [ nip ] assoc-subset + [ word-def peek ] assoc-map % ; + +SYMBOL: math-ops + +[ + \ + define-math-ops + \ - define-math-ops + \ * define-math-ops + \ shift define-math-ops + \ mod define-math-ops + \ /i define-math-ops + + \ bitand define-math-ops + \ bitor define-math-ops + \ bitxor define-math-ops + + \ < define-math-ops + \ <= define-math-ops + \ > define-math-ops + \ >= define-math-ops + \ number= define-math-ops + + \ + \ fixnum+ \ bignum+ define-integer-ops + \ - \ fixnum- \ bignum- define-integer-ops + \ * \ fixnum* \ bignum* define-integer-ops + \ shift \ fixnum-shift \ bignum-shift define-integer-ops + \ mod \ fixnum-mod \ bignum-mod define-integer-ops + \ /i \ fixnum/i \ bignum/i define-integer-ops + + \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops + \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops + \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops + + \ < \ fixnum< \ bignum< define-integer-ops + \ <= \ fixnum<= \ bignum<= define-integer-ops + \ > \ fixnum> \ bignum> define-integer-ops + \ >= \ fixnum>= \ bignum>= define-integer-ops + \ number= \ eq? \ bignum= define-integer-ops +] { } make >hashtable math-ops set-global + +SYMBOL: fast-math-ops + +[ + { { + fixnum fixnum } fixnum+fast } , + { { - fixnum fixnum } fixnum-fast } , + { { * fixnum fixnum } fixnum*fast } , + { { shift fixnum fixnum } fixnum-shift-fast } , + + \ + \ fixnum+fast \ bignum+ define-integer-ops + \ - \ fixnum-fast \ bignum- define-integer-ops + \ * \ fixnum*fast \ bignum* define-integer-ops + \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops +] { } make >hashtable fast-math-ops set-global + +>> + +: math-op ( word left right -- word' ? ) + 3array math-ops get at* ; + +: math-method* ( word left right -- quot ) + 3dup math-op + [ >r 3drop r> 1quotation ] [ drop math-method ] if ; + +: math-both-known? ( word left right -- ? ) + 3dup math-op + [ 2drop 2drop t ] + [ drop math-class-max swap specific-method >boolean ] if ; + +: (derived-ops) ( word assoc -- words ) + swap [ rot first eq? nip ] curry assoc-subset values ; + +: derived-ops ( word -- words ) + [ 1array ] + [ math-ops get (derived-ops) ] + bi append ; + +: fast-derived-ops ( word -- words ) + fast-math-ops get (derived-ops) ; + +: all-derived-ops ( word -- words ) + [ derived-ops ] [ fast-derived-ops ] bi append ; + +: each-derived-op ( word quot -- ) + >r derived-ops r> each ; inline From 7516041e3650adf3f9eb822f3901910e32ba2476 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 18 Apr 2008 16:56:47 -0500 Subject: [PATCH 030/220] Try to fix includes for stesch --- vm/os-macosx-ppc.h | 2 ++ vm/os-macosx-x86.32.h | 2 ++ vm/os-macosx-x86.64.h | 2 ++ 3 files changed, 6 insertions(+) diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h index 640aeb796d..13213acbbc 100644 --- a/vm/os-macosx-ppc.h +++ b/vm/os-macosx-ppc.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ +#include + #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) #define MACH_EXC_STATE_TYPE ppc_exception_state_t diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h index d5e5827a5c..7c830c775d 100644 --- a/vm/os-macosx-x86.32.h +++ b/vm/os-macosx-x86.32.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ +#include + #define MACH_EXC_STATE_TYPE i386_exception_state_t #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.h index d2bb48c3fe..b11aa80ce8 100644 --- a/vm/os-macosx-x86.64.h +++ b/vm/os-macosx-x86.64.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov and Daniel Ehrenberg */ +#include + #define MACH_EXC_STATE_TYPE x86_exception_state64_t #define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 #define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT From 6edac99d83e5fc594b3ce4451d0095d92cbbd6d4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 18 Apr 2008 19:22:53 -0500 Subject: [PATCH 031/220] newfx: minor additions --- extra/newfx/newfx.factor | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 6a191f0e07..3e5f66eb6f 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -155,6 +155,23 @@ METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: prefix-on ( elt seq -- seq ) swap prefix ; +: suffix-on ( elt seq -- seq ) swap suffix ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 1st 0 at ; +: 2nd 1 at ; +: 3rd 2 at ; +: 4th 3 at ; +: 5th 4 at ; +: 6th 5 at ; +: 7th 6 at ; +: 8th 7 at ; +: 9th 8 at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! A note about the 'mutate' qualifier. Other words also technically mutate ! their primary object. However, the 'mutate' qualifier is supposed to ! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file From 0fd4acb85e7ca2665bfd92dd78396d9e90565ee5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 18 Apr 2008 19:23:30 -0500 Subject: [PATCH 032/220] shell: Add pipeline syntax --- extra/shell/parser/parser.factor | 78 +++++++++++++++++++------------- extra/shell/shell.factor | 34 +++++++++++--- 2 files changed, 74 insertions(+), 38 deletions(-) diff --git a/extra/shell/parser/parser.factor b/extra/shell/parser/parser.factor index 4e3ae8069c..c5c352c313 100644 --- a/extra/shell/parser/parser.factor +++ b/extra/shell/parser/parser.factor @@ -1,27 +1,43 @@ -USING: kernel arrays strings sequences sequences.deep peg peg.ebnf ; +USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf + newfx ; IN: shell.parser ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: incantation command stdin stdout background ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - +TUPLE: basic-expr command stdin stdout background ; +TUPLE: pipeline-expr commands stdin stdout background ; TUPLE: single-quoted-expr expr ; TUPLE: double-quoted-expr expr ; TUPLE: back-quoted-expr expr ; TUPLE: glob-expr expr ; - -TUPLE: variable-expr expr ; +TUPLE: variable-expr expr ; +TUPLE: factor-expr expr ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: single-quoted-expr boa ; -: double-quoted-expr boa ; -: back-quoted-expr boa ; -: glob-expr boa ; +: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ; + +: ast>pipeline-expr ( ast -- obj ) + pipeline-expr new + over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands + over 2nd >>stdin + over 5th >>stdout + swap 6th >>background ; + +: ast>single-quoted-expr ( ast -- obj ) + 2nd >string single-quoted-expr boa ; + +: ast>double-quoted-expr ( ast -- obj ) + 2nd >string double-quoted-expr boa ; + +: ast>back-quoted-expr ( ast -- obj ) + 2nd >string back-quoted-expr boa ; + +: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ; + +: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -33,45 +49,43 @@ tab = "\t" white = (space | tab) -whitespace = (white)* => [[ drop ignore ]] +_ = (white)* => [[ drop ignore ]] -squote = "'" +sq = "'" +dq = '"' +bq = "`" -single-quoted = squote (!(squote) .)* squote => [[ second >string ]] +single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]] +double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]] +back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]] -dquote = '"' - -double-quoted = dquote (!(dquote) .)* dquote => [[ second >string ]] - -bquote = "`" - -back-quoted = bquote (!(bquote) .)* bquote => [[ second >string ]] - -variable = "$" other => [[ second variable-expr boa ]] +variable = "$" other => [[ ast>variable-expr ]] glob-char = ("*" | "?") non-glob-char = !(glob-char | white) . -glob-beginning-string = (non-glob-char)* [[ >string ]] +glob-beginning-string = (non-glob-char)* => [[ >string ]] -glob-rest-string = (non-glob-char)+ [[ >string ]] +glob-rest-string = (non-glob-char)+ => [[ >string ]] -glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ flatten concat ]] +glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]] -other = (!(white | "&" | ">" | ">>" | "<") .)+ => [[ >string ]] +other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]] element = (single-quoted | double-quoted | back-quoted | variable | glob | other) -to-file = ">" whitespace other => [[ second ]] +command = (element _)+ -in-file = "<" whitespace other => [[ second ]] +to-file = ">" _ other => [[ second ]] +in-file = "<" _ other => [[ second ]] +ap-file = ">>" _ other => [[ second ]] -ap-file = ">>" whitespace other => [[ second ]] +basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]] -redirection = (in-file)? whitespace (to-file | ap-file)? +pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]] -line = (element whitespace)+ (in-file)? whitespace (to-file | ap-file)? whitespace ("&")? => [[ first4 incantation boa ]] +submission = (pipeline | basic) ;EBNF diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index f36b6f6400..7482f388f1 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -49,22 +49,44 @@ METHOD: expand { object } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run-incantation ( incantation -- ) +: run-sword ( basic-expr -- ) command>> unclip "shell" lookup execute ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-foreground ( process -- ) + [ try-process ] [ print-error drop ] recover ; + +: run-background ( process -- ) run-detached drop ; + +: run-basic-expr ( basic-expr -- ) over command>> expansion >>command over stdin>> >>stdin over stdout>> >>stdout swap background>> - [ run-detached drop ] - [ [ try-process ] [ print-error drop ] recover ] + [ run-background ] + [ run-foreground ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: chant ( incantation -- ) +: basic-chant ( basic-expr -- ) dup command>> first swords member-of? - [ command>> unclip "shell" lookup execute ] - [ run-incantation ] + [ run-sword ] + [ run-basic-expr ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: pipeline-chant ( pipeline-chant -- ) + drop "ix: pipelines not supported" print ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: chant ( obj -- ) + dup basic-expr? + [ basic-chant ] + [ pipeline-chant ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 27d60007e2c512fdd5e23dfccefb7cd6d4adc0f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:18 -0500 Subject: [PATCH 033/220] Clean up recursive benchmark a tad --- extra/benchmark/recursive/recursive.factor | 43 +++++++++++----------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index ee66e303ec..f69547df60 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -1,38 +1,37 @@ +USING: math kernel hints prettyprint io combinators ; IN: benchmark.recursive -USING: math kernel hints prettyprint io ; : fib ( m -- n ) - dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; + dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ; + inline : ack ( m n -- x ) - over zero? [ - nip 1+ - ] [ - dup zero? [ - drop 1- 1 ack - ] [ - dupd 1- ack >r 1- r> ack - ] if - ] if ; + { + { [ over zero? ] [ nip 1+ ] } + { [ dup zero? ] [ drop 1- 1 ack ] } + [ [ drop 1- ] [ 1- ack ] 2bi ack ] + } cond ; inline : tak ( x y z -- t ) - 2over swap < [ - [ rot 1- -rot tak ] 3keep - [ -rot 1- -rot tak ] 3keep - 1- -rot tak - tak - ] [ + 2over <= [ 2nip - ] if ; + ] [ + [ rot 1- -rot tak ] + [ -rot 1- -rot tak ] + [ 1- -rot tak ] + 3tri + tak + ] if ; inline : recursive ( n -- ) - 3 over ack . flush - dup 27.0 + fib . flush - 1- - dup 3 * over 2 * rot tak . flush + [ 3 swap ack . flush ] + [ 27.0 + fib . flush ] + [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri 3 fib . flush 3.0 2.0 1.0 tak . flush ; +HINTS: recursive fixnum ; + : recursive-main 11 recursive ; MAIN: recursive-main From d7763d6b71c031da74f38933ebb4c99363a8a10a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:30 -0500 Subject: [PATCH 034/220] Add another unit test --- core/alien/compiler/compiler-tests.factor | 4 ++++ vm/ffi_test.c | 7 +++++++ vm/ffi_test.h | 2 ++ 3 files changed, 13 insertions(+) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index f0c0706a3c..d1a14dd758 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test +FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + +[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test + ! Test callbacks : callback-1 "void" { } "cdecl" [ ] alien-callback ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 48b6297cb8..5dcff831df 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -260,3 +260,10 @@ int ffi_test_37(int (*f)(int, int, int)) fflush(stdout); return global_var; } + +unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) +{ + return x * y; +} + + diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 2edebd96f1..9a3f4dded2 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -63,3 +63,5 @@ struct test_struct_12 { int a; double x; }; DLLEXPORT double ffi_test_36(struct test_struct_12 x); DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); + +DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y); From 3b795b6a079bccb7a7bb94d003bffd8279c8bfe5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:40 -0500 Subject: [PATCH 035/220] Fix class< bug --- core/classes/algebra/algebra-tests.factor | 44 ++++++++++++++++++++++- core/classes/algebra/algebra.factor | 7 ++-- 2 files changed, 46 insertions(+), 5 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index d61b62af3b..dba97c16f5 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects kernel.private ; +random inference effects kernel.private sbufs ; : class= [ class< ] 2keep swap class< and ; @@ -144,6 +144,48 @@ UNION: z1 b1 c1 ; [ f ] [ null class-not null class= ] unit-test +[ t ] [ + fixnum class-not + fixnum fixnum class-not class-or + class< +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +[ f ] [ null { number fixnum null } min-class ] unit-test + ! Test for hangs? : random-class classes random ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b7a3e074e5..f2941e3cef 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -77,10 +77,10 @@ C: anonymous-complement { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } { [ over anonymous-union? ] [ left-anonymous-union< ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } - { [ over anonymous-complement? ] [ 2drop f ] } { [ over members ] [ left-union-class< ] } { [ dup anonymous-union? ] [ right-anonymous-union< ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } + { [ over anonymous-complement? ] [ 2drop f ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } @@ -193,9 +193,8 @@ C: anonymous-complement [ ] unfold nip ; : min-class ( class seq -- class/f ) - [ dupd classes-intersect? ] subset dup empty? [ - 2drop f - ] [ + over [ classes-intersect? ] curry subset + dup empty? [ 2drop f ] [ tuck [ class< ] with all? [ peek ] [ drop f ] if ] if ; From 6dedc433d510d137db4af36b5ab7fe2860d667a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:55 -0500 Subject: [PATCH 036/220] Improve recursive word type inference --- core/inference/backend/backend-docs.factor | 4 - core/inference/backend/backend.factor | 39 ++-- core/inference/class/class-tests.factor | 79 +++++++- core/inference/class/class.factor | 191 ++++++++++++-------- core/inference/dataflow/dataflow.factor | 5 +- core/optimizer/collect/collect.factor | 10 + core/optimizer/control/control-tests.factor | 32 ++-- core/optimizer/control/control.factor | 3 +- core/optimizer/def-use/def-use-tests.factor | 4 +- core/optimizer/def-use/def-use.factor | 50 ++--- core/optimizer/inlining/inlining.factor | 3 +- core/optimizer/math/math.factor | 75 +++----- core/optimizer/optimizer-tests.factor | 43 +---- core/optimizer/optimizer.factor | 11 +- 14 files changed, 317 insertions(+), 232 deletions(-) create mode 100644 core/optimizer/collect/collect.factor diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 0125f04efa..91314d1312 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -48,10 +48,6 @@ HELP: no-effect { $description "Throws a " { $link no-effect } " error." } { $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ; -HELP: collect-recursion -{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } } -{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ; - HELP: inline-word { $values { "word" word } } { $description "Called during inference to infer stack effects of inline words." diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index e0cc1a5839..f60748a5ac 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ; \ recursive-declare-error inference-error ] if* ; +GENERIC: collect-label-info* ( label node -- ) + +M: node collect-label-info* 2drop ; + +: (collect-label-info) ( label node vector -- ) + >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ; + inline + +M: #call-label collect-label-info* + over calls>> (collect-label-info) ; + +M: #return collect-label-info* + over returns>> (collect-label-info) ; + +: collect-label-info ( #label -- ) + V{ } clone >>calls + V{ } clone >>returns + dup [ collect-label-info* ] with each-node ; + : nest-node ( -- ) #entry node, ; : unnest-node ( new-node -- new-node ) @@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ; : gensym dup t "inlined-block" set-word-prop ; -: inline-block ( word -- node-block data ) +: inline-block ( word -- #label data ) [ copy-inference nest-node dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node + dup collect-label-info ] H{ } make-assoc ; -GENERIC: collect-recursion* ( label node -- ) - -M: node collect-recursion* 2drop ; - -M: #call-label collect-recursion* - tuck node-param eq? [ , ] [ drop ] if ; - -: collect-recursion ( #label -- seq ) - dup node-param - [ [ swap collect-recursion* ] curry each-node ] { } make ; - -: join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get suffix +: join-values ( #label -- ) + calls>> [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; @@ -460,7 +469,7 @@ M: #call-label collect-recursion* drop join-values inline-block apply-infer r> over set-node-in-d dup node, - collect-recursion [ + calls>> [ [ flatten-curries ] modify-values ] each ] [ diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index dcd83f7f7c..3f242261fd 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts vectors optimizer.math.partial ; +system layouts vectors optimizer.math.partial accessors +optimizer.inlining ; + +[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test + +[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -268,19 +273,24 @@ M: float detect-float ; [ 3 + = ] \ equal? inlined? ] unit-test -[ t ] [ +[ f ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ shift inlined? + \ fixnum-shift-fast inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 1 swap 7 bitand shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? +] unit-test + +[ f ] [ + [ { fixnum fixnum } declare 1 swap 7 bitand shift ] + { fixnum-shift-fast } inlined? ] unit-test cell-bits 32 = [ @@ -375,25 +385,78 @@ cell-bits 32 = [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test +: rec ( a -- b ) + dup 0 > [ 1 - rec ] when ; inline + +[ t ] [ + [ { fixnum } declare rec 1 + ] + { > - + } inlined? +] unit-test + : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline [ t ] [ - [ 27.0 fib ] { < - } inlined? + [ 27.0 fib ] { < - + } inlined? +] unit-test + +[ f ] [ + [ 27.0 fib ] { +-integer-integer } inlined? ] unit-test [ t ] [ - [ 27 fib ] { < - } inlined? + [ 27 fib ] { < - + } inlined? ] unit-test [ t ] [ - [ 27 >bignum fib ] { < - } inlined? + [ 27 >bignum fib ] { < - + } inlined? ] unit-test [ f ] [ [ 27/2 fib ] { < - } inlined? ] unit-test +: hang-regression ( m n -- x ) + over 0 number= [ + nip + ] [ + dup [ + drop 1 hang-regression + ] [ + dupd hang-regression hang-regression + ] if + ] if ; inline + +[ t ] [ + [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if +] { } inlined? ] unit-test + +: detect-null ( a -- b ) dup drop ; + +\ detect-null { + { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] } +} define-optimizers + +[ t ] [ + [ { null } declare detect-null ] \ detect-null inlined? +] unit-test + +[ t ] [ + [ { null null } declare + detect-null ] \ detect-null inlined? +] unit-test + +[ f ] [ + [ { null fixnum } declare + detect-null ] \ detect-null inlined? +] unit-test + +GENERIC: detect-integer ( a -- b ) + +M: integer detect-integer ; + +[ t ] [ + [ { null fixnum } declare + detect-integer ] \ detect-integer inlined? +] unit-test + [ t ] [ [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? ] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 1c0f5a46e1..c2629f107f 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables inference kernel math namespaces sequences words parser math.intervals effects classes classes.algebra inference.dataflow -inference.backend combinators ; +inference.backend combinators accessors ; IN: inference.class ! Class inference @@ -25,12 +25,10 @@ C: literal-constraint M: literal-constraint equal? over literal-constraint? [ - 2dup - [ literal-constraint-literal ] bi@ eql? >r - [ literal-constraint-value ] bi@ = r> and - ] [ - 2drop f - ] if ; + [ [ literal>> ] bi@ eql? ] + [ [ value>> ] bi@ = ] + 2bi and + ] [ 2drop f ] if ; TUPLE: class-constraint class value ; @@ -43,8 +41,8 @@ C: interval-constraint GENERIC: apply-constraint ( constraint -- ) GENERIC: constraint-satisfied? ( constraint -- ? ) -: `input node get node-in-d nth ; -: `output node get node-out-d nth ; +: `input node get in-d>> nth ; +: `output node get out-d>> nth ; : class, , ; : literal, , ; : interval, , ; @@ -84,14 +82,12 @@ SYMBOL: value-classes set-value-interval* ; M: interval-constraint apply-constraint - dup interval-constraint-interval - swap interval-constraint-value intersect-value-interval ; + [ interval>> ] [ value>> ] bi intersect-value-interval ; : set-class-interval ( class value -- ) over class? [ - over "interval" word-prop [ - >r "interval" word-prop r> set-value-interval* - ] [ 2drop ] if + >r "interval" word-prop r> over + [ set-value-interval* ] [ 2drop ] if ] [ 2drop ] if ; : value-class* ( value -- class ) @@ -110,18 +106,21 @@ M: interval-constraint apply-constraint [ value-class* class-and ] keep set-value-class* ; M: class-constraint apply-constraint - dup class-constraint-class - swap class-constraint-value intersect-value-class ; + [ class>> ] [ value>> ] bi intersect-value-class ; + +: literal-interval ( value -- interval/f ) + dup real? [ [a,a] ] [ drop f ] if ; : set-value-literal* ( literal value -- ) - over class over set-value-class* - over real? [ over [a,a] over set-value-interval* ] when - 2dup assume - value-literals get set-at ; + { + [ >r class r> set-value-class* ] + [ >r literal-interval r> set-value-interval* ] + [ assume ] + [ value-literals get set-at ] + } 2cleave ; M: literal-constraint apply-constraint - dup literal-constraint-literal - swap literal-constraint-value set-value-literal* ; + [ literal>> ] [ value>> ] bi set-value-literal* ; ! For conditionals, an assoc of child node # --> constraint GENERIC: child-constraints ( node -- seq ) @@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- ) M: node infer-classes-before drop ; M: node child-constraints - node-children length + children>> length dup zero? [ drop f ] [ f ] if ; : value-literal* ( value -- obj ? ) value-literals get at* ; M: literal-constraint constraint-satisfied? - dup literal-constraint-value value-literal* - [ swap literal-constraint-literal eql? ] [ 2drop f ] if ; + dup value>> value-literal* + [ swap literal>> eql? ] [ 2drop f ] if ; M: class-constraint constraint-satisfied? - dup class-constraint-value value-class* - swap class-constraint-class class< ; + [ value>> value-class* ] [ class>> ] bi class< ; M: pair apply-constraint first2 2dup constraints get set-at @@ -154,19 +152,18 @@ M: pair apply-constraint M: pair constraint-satisfied? first constraint-satisfied? ; -: extract-keys ( assoc seq -- newassoc ) - dup length swap [ - dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if - ] each nip f assoc-like ; +: extract-keys ( seq assoc -- newassoc ) + [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ; : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. - dup node-values - value-intervals get over extract-keys pick set-node-intervals - value-classes get over extract-keys pick set-node-classes - value-literals get over extract-keys pick set-node-literals - 2drop ; + dup node-values { + [ value-intervals get extract-keys >>intervals ] + [ value-classes get extract-keys >>classes ] + [ value-literals get extract-keys >>literals ] + [ 2drop ] + } cleave ; : intersect-classes ( classes values -- ) [ intersect-value-class ] 2each ; @@ -190,31 +187,29 @@ M: pair constraint-satisfied? ] 2bi ; : compute-constraints ( #call -- ) - dup node-param "constraints" word-prop [ + dup param>> "constraints" word-prop [ call ] [ - dup node-param "predicating" word-prop dup + dup param>> "predicating" word-prop dup [ swap predicate-constraints ] [ 2drop ] if ] if* ; : compute-output-classes ( node word -- classes intervals ) - dup node-param "output-classes" word-prop + dup param>> "output-classes" word-prop dup [ call ] [ 2drop f f ] if ; : output-classes ( node -- classes intervals ) dup compute-output-classes >r - [ ] [ node-param "default-output-classes" word-prop ] ?if + [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; M: #call infer-classes-before - dup compute-constraints - dup node-out-d swap output-classes - >r over intersect-classes - r> swap intersect-intervals ; + [ compute-constraints ] keep + [ output-classes ] [ out-d>> ] bi + tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; M: #push infer-classes-before - node-out-d - [ [ value-literal ] keep set-value-literal* ] each ; + out-d>> [ [ value-literal ] keep set-value-literal* ] each ; M: #if child-constraints [ @@ -224,19 +219,17 @@ M: #if child-constraints M: #dispatch child-constraints dup [ - node-children length [ - 0 `input literal, - ] each + children>> length [ 0 `input literal, ] each ] make-constraints ; M: #declare infer-classes-before - dup node-param swap node-in-d + [ param>> ] [ in-d>> ] bi [ intersect-value-class ] 2each ; DEFER: (infer-classes) : infer-children ( node -- ) - dup node-children swap child-constraints [ + [ children>> ] [ child-constraints ] bi [ [ value-classes [ clone ] change value-literals [ clone ] change @@ -251,17 +244,21 @@ DEFER: (infer-classes) >r dup [ length ] map supremum r> [ pad-left ] 2curry map ; : (merge-classes) ( nodes -- seq ) - [ node-input-classes ] map - null pad-all flip [ null [ class-or ] reduce ] map ; + dup length 1 = [ + first node-input-classes + ] [ + [ node-input-classes ] map null pad-all flip + [ null [ class-or ] reduce ] map + ] if ; : set-classes ( seq node -- ) - node-out-d [ set-value-class* ] 2reverse-each ; + out-d>> [ set-value-class* ] 2reverse-each ; : merge-classes ( nodes node -- ) >r (merge-classes) r> set-classes ; : set-intervals ( seq node -- ) - node-out-d [ set-value-interval* ] 2reverse-each ; + out-d>> [ set-value-interval* ] 2reverse-each ; : merge-intervals ( nodes node -- ) >r @@ -276,28 +273,70 @@ DEFER: (infer-classes) dup node-successor dup #merge? [ swap active-children dup empty? [ 2drop ] [ swap annotate-merge ] if - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; + +: classes= ( inferred current -- ? ) + 2dup min-length [ tail* ] curry bi@ sequence= ; + +SYMBOL: fixed-point? + +SYMBOL: nested-labels : annotate-entry ( nodes #label -- ) - node-child merge-classes ; + >r (merge-classes) r> node-child + 2dup node-output-classes classes= + [ 2drop ] [ set-classes fixed-point? off ] if ; + +: init-recursive-calls ( #label -- ) + #! We set recursive calls to output the empty type, then + #! repeat inference until a fixed point is reached. + #! Hopefully, our type functions are monotonic so this + #! will always converge. + returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ; M: #label infer-classes-before ( #label -- ) - #! First, infer types under the hypothesis which hold on - #! entry to the recursive label. - [ 1array ] keep annotate-entry ; + [ init-recursive-calls ] + [ [ 1array ] keep annotate-entry ] bi ; + +: infer-label-loop ( #label -- ) + fixed-point? on + dup node-child (infer-classes) + dup [ calls>> ] [ suffix ] [ annotate-entry ] tri + fixed-point? get [ drop ] [ infer-label-loop ] if ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - { - [ annotate-node ] - [ infer-classes-before ] - [ infer-children ] - [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] - [ node-child (infer-classes) ] - } cleave ; + [ + { + [ nested-labels get push ] + [ annotate-node ] + [ infer-classes-before ] + [ infer-label-loop ] + [ drop nested-labels get pop* ] + } cleave + ] with-scope ; + +: find-label ( param -- #label ) + param>> nested-labels get [ param>> eq? ] with find nip ; + +M: #call-label infer-classes-before ( #call-label -- ) + [ find-label returns>> (merge-classes) ] [ out-d>> ] bi + [ set-value-class* ] 2each ; + +M: #return infer-classes-around + nested-labels get length 0 > [ + dup param>> nested-labels get peek param>> eq? [ + [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri + classes= [ + drop + ] [ + fixed-point? off + [ in-d>> value-classes get extract-keys ] keep + set-node-classes + ] if + ] [ drop ] if + ] [ drop ] if ; M: object infer-classes-around { @@ -310,11 +349,13 @@ M: object infer-classes-around : (infer-classes) ( node -- ) [ [ infer-classes-around ] - [ node-successor (infer-classes) ] bi + [ node-successor ] bi + (infer-classes) ] when* ; : infer-classes-with ( node classes literals intervals -- ) [ + V{ } clone nested-labels set H{ } assoc-like value-intervals set H{ } assoc-like value-literals set H{ } assoc-like value-classes set @@ -322,13 +363,11 @@ M: object infer-classes-around (infer-classes) ] with-scope ; -: infer-classes ( node -- ) - f f f infer-classes-with ; +: infer-classes ( node -- node ) + dup f f f infer-classes-with ; : infer-classes/node ( node existing -- ) #! Infer classes, using the existing node's class info as a #! starting point. - dup node-classes - over node-literals - rot node-intervals + [ node-classes ] [ node-literals ] [ node-intervals ] tri infer-classes-with ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 3fb047b781..bb66a5386c 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -90,7 +90,7 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label < node word loop? ; +TUPLE: #label < node word loop? returns calls ; : #label ( word label -- node ) \ #label param-node swap >>word ; @@ -290,6 +290,9 @@ SYMBOL: node-stack : node-input-classes ( node -- seq ) dup in-d>> [ node-class ] with map ; +: node-output-classes ( node -- seq ) + dup out-d>> [ node-class ] with map ; + : node-input-intervals ( node -- seq ) dup in-d>> [ node-interval ] with map ; diff --git a/core/optimizer/collect/collect.factor b/core/optimizer/collect/collect.factor new file mode 100644 index 0000000000..6b9aee4e1a --- /dev/null +++ b/core/optimizer/collect/collect.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: inference.dataflow inference.backend kernel ; +IN: optimizer + +: collect-label-infos ( node -- node ) + dup [ + dup #label? [ collect-label-info ] [ drop ] if + ] each-node ; + diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index ce77cdd43a..9c6d041bca 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -27,22 +27,22 @@ optimizer ; dup [ 1+ loop-test-1 ] [ drop ] if ; inline [ t ] [ - [ loop-test-1 ] dataflow dup detect-loops + [ loop-test-1 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ loop-test-1 1 2 3 ] dataflow dup detect-loops + [ loop-test-1 1 2 3 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ (each-integer) label-is-loop? ] unit-test @@ -50,7 +50,7 @@ optimizer ; dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline [ t ] [ - [ loop-test-2 ] dataflow dup detect-loops + [ loop-test-2 ] dataflow detect-loops \ loop-test-2 label-is-not-loop? ] unit-test @@ -58,7 +58,7 @@ optimizer ; dup [ [ loop-test-3 ] each ] [ drop ] if ; inline [ t ] [ - [ loop-test-3 ] dataflow dup detect-loops + [ loop-test-3 ] dataflow detect-loops \ loop-test-3 label-is-not-loop? ] unit-test @@ -73,7 +73,7 @@ optimizer ; dup #label? [ node-successor find-label ] unless ; : test-loop-exits - dataflow dup detect-loops find-label + dataflow detect-loops find-label dup node-param swap [ node-child find-tail find-loop-exits [ class ] map ] keep #label-loop? ; @@ -113,7 +113,7 @@ optimizer ; ] unit-test [ f ] [ - [ [ [ ] map ] map ] dataflow dup detect-loops + [ [ [ ] map ] map ] dataflow detect-loops [ dup #label? swap #loop? not and ] node-exists? ] unit-test @@ -128,22 +128,22 @@ DEFER: a blah [ b ] [ a ] if ; inline [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test [ t ] [ - [ b ] dataflow dup detect-loops + [ b ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test @@ -156,12 +156,12 @@ DEFER: a' blah [ b' ] [ a' ] if ; inline [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ b' label-is-loop? ] unit-test @@ -171,11 +171,11 @@ DEFER: a' ! a standard iterative dataflow problem after all -- so I'm ! tempted to believe the computer here [ t ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ b' label-is-loop? ] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index f9f8901c41..976156db77 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -109,8 +109,9 @@ SYMBOL: potential-loops ] [ 2drop ] if ] assoc-each [ remove-non-loop-calls ] when ; -: detect-loops ( nodes -- ) +: detect-loops ( node -- node ) [ + dup collect-label-info remove-non-tail-calls remove-non-loop-calls diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index f22cce9fa8..914018437a 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; [ 3 { 1 1 1 } ] [ - [ 1 2 3 ] dataflow compute-def-use + [ 1 2 3 ] dataflow compute-def-use drop def-use get values dup length swap [ length ] map ] unit-test : kill-set ( quot -- seq ) - dataflow compute-def-use compute-dead-literals keys + dataflow compute-def-use drop compute-dead-literals keys [ value-literal ] map ; : subset? [ member? ] curry all? ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index 54fca38ee2..66bffd9767 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: optimizer.def-use USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors ; +inference.backend kernel generic assocs classes vectors +accessors combinators ; +IN: optimizer.def-use SYMBOL: def-use @@ -21,17 +22,20 @@ SYMBOL: def-use GENERIC: node-def-use ( node -- ) -: compute-def-use ( node -- ) - H{ } clone def-use set [ node-def-use ] each-node ; +: compute-def-use ( node -- node ) + H{ } clone def-use set + dup [ node-def-use ] each-node ; : nest-def-use ( node -- def-use ) - [ compute-def-use def-use get ] with-scope ; + [ compute-def-use drop def-use get ] with-scope ; : (node-def-use) ( node -- ) - dup dup node-in-d uses-values - dup dup node-in-r uses-values - dup node-out-d defs-values - node-out-r defs-values ; + { + [ dup in-d>> uses-values ] + [ dup in-r>> uses-values ] + [ out-d>> defs-values ] + [ out-r>> defs-values ] + } cleave ; M: object node-def-use (node-def-use) ; @@ -43,7 +47,7 @@ M: #passthru node-def-use drop ; M: #return node-def-use #! Values returned by local labels can be killed. - dup node-param [ drop ] [ (node-def-use) ] if ; + dup param>> [ drop ] [ (node-def-use) ] if ; ! nodes that don't use their values directly UNION: #killable @@ -56,13 +60,13 @@ UNION: #killable M: #label node-def-use [ - dup node-in-d , - dup node-child node-out-d , - dup collect-recursion [ node-in-d , ] each + dup in-d>> , + dup node-child out-d>> , + dup calls>> [ in-d>> , ] each ] { } make purge-invariants uses-values ; : branch-def-use ( #branch -- ) - active-children [ node-in-d ] map + active-children [ in-d>> ] map purge-invariants t swap uses-values ; M: #branch node-def-use @@ -85,16 +89,16 @@ M: node kill-node* drop t ; inline M: #shuffle kill-node* - [ - dup node-in-d empty? swap node-out-d empty? and - ] prune-if ; + [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ; M: #push kill-node* - [ node-out-d empty? ] prune-if ; + [ out-d>> empty? ] prune-if ; -M: #>r kill-node* [ node-in-d empty? ] prune-if ; +M: #>r kill-node* + [ in-d>> empty? ] prune-if ; -M: #r> kill-node* [ node-in-r empty? ] prune-if ; +M: #r> kill-node* + [ in-r>> empty? ] prune-if ; : kill-node ( node -- node ) dup [ @@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; ] if ; : sole-consumer ( #call -- node/f ) - node-out-d first used-by + out-d>> first used-by dup length 1 = [ first ] [ drop f ] if ; : splice-def-use ( node -- ) @@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - [ compute-def-use def-use get keys ] with-scope + nest-def-use keys def-use get [ [ t swap ?push ] change-at ] curry each ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index e74e8b1de2..33c8244b4c 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -71,6 +71,7 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) { + null fixnum bignum integer ratio rational float real @@ -192,7 +193,7 @@ DEFER: (flat-length) nip dup [ second ] when ; : apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + dup find-identity f splice-quot ; : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index fe33c57d42..c0191cf89d 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -8,7 +8,7 @@ namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining -optimizer.math.partial generic.standard system ; +optimizer.math.partial generic.standard system accessors ; : define-math-identities ( word identities -- ) >r all-derived-ops r> define-identities ; @@ -95,22 +95,17 @@ optimizer.math.partial generic.standard system ; } define-math-identities : math-closure ( class -- newclass ) - { fixnum bignum integer rational float real number } + { null fixnum bignum integer rational float real number } [ class< ] with find nip number or ; : fits? ( interval class -- ? ) "interval" word-prop dup [ interval-subset? ] [ 2drop t ] if ; -: math-output-class ( node min -- newclass ) - #! if min is f, it means we just want to use the declared - #! output class from the "infer-effect". - dup [ - swap node-in-d - [ value-class* math-closure math-class-max ] each - ] [ - 2drop f - ] if ; +: math-output-class ( node upgrades -- newclass ) + >r + in-d>> null [ value-class* math-closure math-class-max ] reduce + dup r> at swap or ; : won't-overflow? ( interval node -- ? ) node-in-d [ value-class* fixnum class< ] all? @@ -129,22 +124,17 @@ optimizer.math.partial generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-1 ( node min word -- classes intervals ) - pick >r - >r over r> - math-output-interval-1 - >r math-output-class r> - r> post-process ; inline +: math-output-class/interval-1 ( node word -- classes intervals ) + [ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ; { - { bitnot fixnum interval-bitnot } - { fixnum-bitnot f interval-bitnot } - { bignum-bitnot f interval-bitnot } + { bitnot interval-bitnot } + { fixnum-bitnot interval-bitnot } + { bignum-bitnot interval-bitnot } } [ - first3 [ - math-output-class/interval-1 - ] 2curry "output-classes" set-word-prop -] each + [ math-output-class/interval-1 ] curry + "output-classes" set-word-prop +] assoc-each : intervals ( node -- i1 i2 ) node-in-d first2 [ value-interval* ] bi@ ; @@ -156,7 +146,7 @@ optimizer.math.partial generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-2 ( node min word -- classes intervals ) +: math-output-class/interval-2 ( node upgrades word -- classes intervals ) pick >r >r over r> math-output-interval-2 @@ -164,12 +154,12 @@ optimizer.math.partial generic.standard system ; r> post-process ; inline { - { + integer interval+ } - { - integer interval- } - { * integer interval* } - { / rational interval/ } - { /i integer interval/i } - { shift f interval-shift-safe } + { + { { fixnum integer } } interval+ } + { - { { fixnum integer } } interval- } + { * { { fixnum integer } } interval* } + { / { { fixnum rational } { integer rational } } interval/ } + { /i { { fixnum integer } } interval/i } + { shift { { fixnum integer } } interval-shift-safe } } [ first3 [ [ @@ -178,16 +168,6 @@ optimizer.math.partial generic.standard system ; ] 2curry each-derived-op ] each -\ shift [ - [ - dup - node-in-d second value-interval* - -1./0. 0 [a,b] interval-subset? fixnum integer ? - \ interval-shift-safe - math-output-class/interval-2 - ] "output-classes" set-word-prop -] each-derived-op - : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -216,12 +196,12 @@ optimizer.math.partial generic.standard system ; r> post-process ; inline { - { mod fixnum mod-range } - { rem integer rem-range } + { mod { } mod-range } + { rem { { fixnum integer } } rem-range } - { bitand fixnum bitand-range } - { bitor fixnum f } - { bitxor fixnum f } + { bitand { } bitand-range } + { bitor { } f } + { bitxor { } f } } [ first3 [ [ @@ -311,7 +291,8 @@ most-negative-fixnum most-positive-fixnum [a,b] ! Removing overflow checks : remove-overflow-check? ( #call -- ? ) - dup node-out-d first node-class fixnum class< ; + dup out-d>> first node-class + [ fixnum class< ] [ null eq? not ] bi and ; { { + [ fixnum+fast ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 1a48e353a2..63a63a2f92 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -14,40 +14,6 @@ IN: optimizer.tests H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* ] unit-test -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; @@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ; USE: sequences.private [ ] [ { (3append) } compile ] unit-test + +! Wow +: counter-example ( a b c d -- a' b' c' d' ) + dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline + +: counter-example' ( -- a' b' c' d' ) + 1 2 3.0 3 counter-example ; + +[ 2 4 6.0 0 ] [ counter-example' ] unit-test diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 9e898450cc..23cba3ea4c 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math optimizer.control -optimizer.inlining inference.class ; +optimizer.collect optimizer.inlining inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -10,10 +10,13 @@ IN: optimizer H{ } clone class-substitutions set H{ } clone literal-substitutions set H{ } clone value-substitutions set - dup compute-def-use + + collect-label-infos + compute-def-use kill-values - dup detect-loops - dup infer-classes + detect-loops + infer-classes + optimizer-changed off optimize-nodes optimizer-changed get From f48d5091c96ee8e218da75bd9ce9c02daa6841b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 04:52:34 -0500 Subject: [PATCH 037/220] Faster inline allocators --- core/cpu/architecture/architecture.factor | 3 +++ core/cpu/ppc/allot/allot.factor | 15 ++++++++++++++- core/cpu/x86/32/32.factor | 2 ++ core/cpu/x86/64/64.factor | 2 ++ core/cpu/x86/allot/allot.factor | 19 ++++++++++++++++--- core/cpu/x86/architecture/architecture.factor | 4 ++++ core/generator/registers/registers.factor | 5 ----- core/inference/class/class-tests.factor | 10 ++++++++++ core/math/math.factor | 2 +- core/optimizer/math/math.factor | 4 ++-- vm/data_gc.c | 19 +++++++++---------- vm/data_gc.h | 15 ++++++++------- vm/debug.c | 6 +++++- vm/errors.c | 2 +- 14 files changed, 77 insertions(+), 31 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8c9db6c7e8..4e939bddb8 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -187,6 +187,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- ) HOOK: %box-alien cpu ( dst src -- ) +! GC check +HOOK: %gc cpu + : operand ( var -- op ) get v>operand ; inline : unique-operands ( operands quot -- ) diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 34ea82dc4e..47dc6b1570 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -7,7 +7,7 @@ cpu.architecture alien ; IN: cpu.ppc.allot : load-zone-ptr ( reg -- ) - "nursery" f pick %load-dlsym dup 0 LWZ ; + "nursery" f pick %load-dlsym ; : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the @@ -25,6 +25,19 @@ IN: cpu.ppc.allot : %store-tagged ( reg tag -- ) >r dup fresh-object v>operand 11 r> tag-number ORI ; +M: ppc %gc + "end" define-label + 12 load-zone-ptr + 11 12 cell LWZ ! nursery.here -> r11 + 12 12 3 cells LWZ ! nursery.end -> r12 + 11 12 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + 0 11 12 CMPI ! is here >= end? + "end" get BLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : %allot-float ( reg -- ) #! exits with tagged ptr to object in r12, untagged in r11 float 16 %allot diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 985f717035..50e38f2082 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 stack-save-reg EDX ; +M: x86.32 temp-reg-1 EAX ; +M: x86.32 temp-reg-2 ECX ; M: temp-reg v>operand drop EBX ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 99f567f448..d79ce58d88 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; M: x86.64 stack-save-reg RSI ; +M: x86.64 temp-reg-1 RAX ; +M: x86.64 temp-reg-2 RCX ; M: temp-reg v>operand drop RBX ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f236cdcfa6..bfcede7ef7 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -16,12 +16,12 @@ IN: cpu.x86.allot : object@ ( n -- operand ) cells (object@) ; -: load-zone-ptr ( -- ) +: load-zone-ptr ( reg -- ) #! Load pointer to start of zone array - "nursery" f allot-reg %alien-global ; + 0 MOV "nursery" f rc-absolute-cell rel-dlsym ; : load-allot-ptr ( -- ) - load-zone-ptr + allot-reg load-zone-ptr allot-reg PUSH allot-reg dup cell [+] MOV ; @@ -29,6 +29,19 @@ IN: cpu.x86.allot allot-reg POP allot-reg cell [+] swap 8 align ADD ; +M: x86.32 %gc ( -- ) + "end" define-label + temp-reg-1 load-zone-ptr + temp-reg-2 temp-reg-1 cell [+] MOV + temp-reg-2 1024 ADD + temp-reg-1 temp-reg-1 3 cells [+] MOV + temp-reg-2 temp-reg-1 CMP + "end" get JLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : store-header ( header -- ) 0 object@ swap type-number tag-fixnum MOV ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index fa1c9c8768..7e7ff8a334 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -34,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) +! Only used by inline allocation +HOOK: temp-reg-1 cpu +HOOK: temp-reg-2 cpu + HOOK: address-operand cpu ( address -- operand ) HOOK: fixnum>slot@ cpu diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 3b5b6ad096..a3198784ee 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -468,11 +468,6 @@ M: loc lazy-store : finalize-contents ( -- ) finalize-locs finalize-vregs reset-phantoms ; -: %gc ( -- ) - 0 frame-required - %prepare-alien-invoke - "simple_gc" f %alien-invoke ; - ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) double-float-regs free-vregs length <= diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3f242261fd..0c4ff82798 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -305,6 +305,11 @@ cell-bits 32 = [ ] unit-test ] when +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + [ t ] [ [ B{ 1 0 } *short 0 number= ] \ number= inlined? @@ -557,6 +562,11 @@ M: integer detect-integer ; ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? ] unit-test +[ t ] [ + [ { integer } declare bitnot detect-integer ] + \ detect-integer inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/math/math.factor b/core/math/math.factor index 6a56baea3a..14cbe68351 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -122,7 +122,7 @@ M: float fp-nan? : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable : power-of-2? ( n -- ? ) - dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable + dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable : align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index c0191cf89d..ab8a1f3eda 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -125,7 +125,8 @@ optimizer.math.partial generic.standard system accessors ; ] if ; inline : math-output-class/interval-1 ( node word -- classes intervals ) - [ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ; + [ drop { } math-output-class 1array ] + [ math-output-interval-1 1array ] 2bi ; { { bitnot interval-bitnot } @@ -362,7 +363,6 @@ most-negative-fixnum most-positive-fixnum [a,b] { + [ [ >fixnum ] bi@ fixnum+fast ] } { - [ [ >fixnum ] bi@ fixnum-fast ] } { * [ [ >fixnum ] bi@ fixnum*fast ] } - { shift [ [ >fixnum ] bi@ fixnum-shift-fast ] } } [ >r derived-ops r> [ [ diff --git a/vm/data_gc.c b/vm/data_gc.c index 86552d6401..5aa47c8c6c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -122,7 +122,7 @@ void clear_cards(CELL from, CELL to) void set_data_heap(F_DATA_HEAP *data_heap_) { data_heap = data_heap_; - nursery = &data_heap->generations[NURSERY]; + nursery = data_heap->generations[NURSERY]; init_cards_offset(); clear_cards(NURSERY,TENURED); } @@ -231,7 +231,7 @@ DEFINE_PRIMITIVE(data_room) for(gen = 0; gen < data_heap->gen_count; gen++) { - F_ZONE *z = &data_heap->generations[gen]; + F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10)); set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10)); } @@ -583,7 +583,7 @@ CELL collect_next(CELL scan) INLINE void reset_generation(CELL i) { - F_ZONE *z = &data_heap->generations[i]; + F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); z->here = z->start; if(secure_gc) memset((void*)z->start,69,z->size); @@ -608,7 +608,7 @@ void begin_gc(CELL requested_bytes) old_data_heap = data_heap; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data_heap->generations[collecting_gen]; + newspace = &data_heap->generations[TENURED]; } else if(collecting_accumulation_gen_p()) { @@ -783,6 +783,11 @@ void gc(void) garbage_collection(TENURED,false,0); } +void minor_gc(void) +{ + garbage_collection(NURSERY,false,0); +} + DEFINE_PRIMITIVE(gc) { gc(); @@ -794,12 +799,6 @@ DEFINE_PRIMITIVE(gc_time) box_unsigned_8(gc_time); } -void simple_gc(void) -{ - if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end) - garbage_collection(NURSERY,false,0); -} - DEFINE_PRIMITIVE(become) { F_ARRAY *new_objects = untag_array(dpop()); diff --git a/vm/data_gc.h b/vm/data_gc.h index 2490ed8805..be9ed159b7 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -20,6 +20,7 @@ DECLARE_PRIMITIVE(next_object); DECLARE_PRIMITIVE(end_scan); void gc(void); +DLLEXPORT void minor_gc(void); /* generational copying GC divides memory into zones */ typedef struct { @@ -125,7 +126,7 @@ void collect_cards(void); F_ZONE *newspace; /* new objects are allocated here */ -DLLEXPORT F_ZONE *nursery; +DLLEXPORT F_ZONE nursery; INLINE bool in_zone(F_ZONE *z, CELL pointer) { @@ -200,7 +201,7 @@ INLINE bool should_copy(CELL untagged) else if(HAVE_AGING_P && collecting_gen == AGING) return !in_zone(&data_heap->generations[TENURED],untagged); else if(HAVE_NURSERY_P && collecting_gen == NURSERY) - return in_zone(&data_heap->generations[NURSERY],untagged); + return in_zone(&nursery,untagged); else { critical_error("Bug in should_copy",untagged); @@ -315,13 +316,15 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a) + if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ - if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end) + if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) garbage_collection(NURSERY,false,0); - object = allot_zone(nursery,a); + CELL h = nursery.here; + nursery.here = h + align8(a); + object = (void*)h; } /* If the object is bigger than the nursery, allocate it in tenured space */ @@ -360,8 +363,6 @@ INLINE void* allot_object(CELL type, CELL a) CELL collect_next(CELL scan); -DLLEXPORT void simple_gc(void); - DECLARE_PRIMITIVE(gc); DECLARE_PRIMITIVE(gc_time); DECLARE_PRIMITIVE(become); diff --git a/vm/debug.c b/vm/debug.c index 840d252769..b86ec808bc 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -227,7 +227,11 @@ void dump_zone(F_ZONE *z) void dump_generations(void) { int i; - for(i = 0; i < data_heap->gen_count; i++) + + printf("Nursery: "); + dump_zone(&nursery); + + for(i = 1; i < data_heap->gen_count; i++) { printf("Generation %d: ",i); dump_zone(&data_heap->generations[i]); diff --git a/vm/errors.c b/vm/errors.c index 6d99d34766..57dc8b66a1 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -96,7 +96,7 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); else if(in_page(addr, rs_bot, rs_size, 0)) general_error(ERROR_RS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, nursery->end, 0, 0)) + else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); else if(in_page(addr, gc_locals_region->start, 0, -1)) critical_error("gc locals underflow",0); From 7faa9a831284d4ff18c8a21680f95b40d34ee4fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 04:52:50 -0500 Subject: [PATCH 038/220] Oops --- extra/project-euler/150/150.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 5d83f5a732..c96c1ebc73 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -31,7 +31,7 @@ IN: project-euler.150 : sums-triangle ( -- seq ) 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; -PRIVATE> USING: arrays kernel.private ; +PRIVATE> :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | From 827d0653a558903d5cb9f033c61cdc8bc423e9fd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 19 Apr 2008 14:10:40 -0500 Subject: [PATCH 039/220] ix: Add syntax and implementation for executing inline Factor code --- extra/shell/parser/parser.factor | 9 ++++++--- extra/shell/shell.factor | 8 ++++++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/extra/shell/parser/parser.factor b/extra/shell/parser/parser.factor index c5c352c313..46548bb34f 100644 --- a/extra/shell/parser/parser.factor +++ b/extra/shell/parser/parser.factor @@ -39,6 +39,8 @@ TUPLE: factor-expr expr ; : ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ; +: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! EBNF: expr @@ -59,6 +61,8 @@ single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]] double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]] back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]] +factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]] + variable = "$" other => [[ ast>variable-expr ]] glob-char = ("*" | "?") @@ -73,7 +77,7 @@ glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]] -element = (single-quoted | double-quoted | back-quoted | variable | glob | other) +element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other) command = (element _)+ @@ -87,5 +91,4 @@ pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file submission = (pipeline | basic) -;EBNF - +;EBNF \ No newline at end of file diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 7482f388f1..57a7a7a327 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -1,5 +1,6 @@ -USING: kernel words continuations namespaces debugger sequences combinators +USING: kernel parser words continuations namespaces debugger + sequences combinators prettyprint system io io.files io.launcher sequences.deep accessors multi-methods newfx shell.parser ; @@ -41,6 +42,8 @@ METHOD: expand { glob-expr } [ ] if ; +METHOD: expand { factor-expr } expr>> eval unparse ; + METHOD: expand { object } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -49,7 +52,8 @@ METHOD: expand { object } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run-sword ( basic-expr -- ) command>> unclip "shell" lookup execute ; +: run-sword ( basic-expr -- ) + command>> expansion unclip "shell" lookup execute ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From b257640f97885aade8e4364216de9d233d7cddc3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:27:46 -0500 Subject: [PATCH 040/220] remove ?head* --- extra/sequences/lib/lib.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 15983329d6..6bc6c706cf 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -197,9 +197,6 @@ USE: continuations >r >r 0 max r> r> [ length tuck min >r min r> ] keep subseq ; -: ?head* ( seq n -- seq/f ) (head) ?subseq ; -: ?tail* ( seq n -- seq/f ) (tail) ?subseq ; - : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; inline From a81aaa61009f3d84983b1004e94f925f466d4ea7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:27:54 -0500 Subject: [PATCH 041/220] add random-id, still needs to retry if insert fails --- extra/db/db.factor | 6 +-- extra/db/sql/sql.factor | 6 +-- extra/db/sqlite/ffi/ffi.factor | 10 ++++- extra/db/sqlite/lib/lib.factor | 17 ++++++-- extra/db/sqlite/sqlite.factor | 34 +++++++++++++-- extra/db/tuples/tuples-tests.factor | 57 +++++++++++++++++++++---- extra/db/tuples/tuples.factor | 23 ++++++----- extra/db/types/types.factor | 64 ++++++++++++++++++----------- 8 files changed, 158 insertions(+), 59 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 7a28dea558..ce6232f414 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -36,7 +36,7 @@ HOOK: db-close db ( handle -- ) ] with-variable ; ! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? type quot ; +TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; @@ -62,13 +62,9 @@ SINGLETON: retryable over sequence? [ [ make-retryable ] curry map ] [ - >>quot retryable >>type ] if ; -: handle-random-id ( statement -- ) - drop ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index d7ef986ea6..4561424a9d 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -38,7 +38,7 @@ DEFER: sql% { \ select [ "(select" sql% sql% ")" sql% ] } { \ table [ sql% ] } { \ set [ "set" "," sql-interleave ] } - { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } { \ count [ "count" sql-function, ] } { \ sum [ "sum" sql-function, ] } { \ avg [ "avg" sql-function, ] } @@ -47,7 +47,7 @@ DEFER: sql% [ sql% [ sql% ] each ] } case ; -TUPLE: no-sql-match ; +ERROR: no-sql-match ; : sql% ( obj -- ) { { [ dup string? ] [ " " 0% 0% ] } @@ -56,7 +56,7 @@ TUPLE: no-sql-match ; { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } { [ dup quotation? ] [ call ] } - [ T{ no-sql-match } throw ] + [ no-sql-match ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index c724025874..6b94c02c65 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -3,7 +3,7 @@ ! An interface to the sqlite database. Tested against sqlite v3.1.3. ! Not all functions have been wrapped. USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; + system combinators alien.c-types ; IN: db.sqlite.ffi << "sqlite" { @@ -112,11 +112,14 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +: sqlite3-bind-uint64 ( pStmt index in64 -- int ) + "int" "sqlite" "sqlite3_bind_int64" + { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -126,6 +129,9 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +: sqlite3-column-uint64 ( pStmt col -- uint64 ) + "sqlite3_uint64" "sqlite" "sqlite3_column_int64" + { "sqlite3_stmt*" "int" } alien-invoke ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b6221e5a1e..61070b078b 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -52,6 +52,9 @@ IN: db.sqlite.lib : sqlite-bind-int64 ( handle i n -- ) sqlite3_bind_int64 sqlite-check-result ; +: sqlite-bind-uint64 ( handle i n -- ) + sqlite3-bind-uint64 sqlite-check-result ; + : sqlite-bind-double ( handle i x -- ) sqlite3_bind_double sqlite-check-result ; @@ -69,7 +72,10 @@ IN: db.sqlite.lib parameter-index sqlite-bind-int ; : sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int ; + parameter-index sqlite-bind-int64 ; + +: sqlite-bind-uint64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-uint64 ; : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; @@ -86,6 +92,8 @@ IN: db.sqlite.lib { { INTEGER [ sqlite-bind-int-by-name ] } { BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } @@ -99,6 +107,7 @@ IN: db.sqlite.lib sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } + { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -121,10 +130,12 @@ IN: db.sqlite.lib : sqlite-column-typed ( handle index type -- obj ) dup array? [ first ] when { - { +native-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3_column_int64 ] } + { +native-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3-column-uint64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } + { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } { DOUBLE [ sqlite3_column_double ] } { TEXT [ sqlite3_column_text ] } { VARCHAR [ sqlite3_column_text ] } diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e2ea28fe9a..5f8247f67b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges ; +io namespaces.lib accessors vectors math.ranges random +math.bitfields.lib ; USE: tools.walker IN: db.sqlite @@ -65,6 +66,9 @@ M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; +M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ; + M: sqlite-statement bind-tuple ( tuple statement -- ) [ in-params>> [ sqlite-bind-conversion ] with map @@ -105,8 +109,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - - dup handle-random-id ; inline + ; M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -129,7 +132,21 @@ M: sqlite-db ( tuple -- statement ) maybe-remove-id dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ +break + dup modifiers>> find-random-generator + [ + [ + column-name>> ":" prepend + dup 0% random-id-quot + ] with-random + ] curry + [ type>> ] bi 10 1, + ] [ + bind% + ] if + ] interleave ");" 0% ] sqlite-make ; @@ -219,6 +236,9 @@ M: sqlite-db ( tuple class -- statement ) dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] sqlite-make ; +M: sqlite-db random-id-quot ( -- quot ) + [ 64 [ 2^ random ] keep 1 - set-bit ] ; + M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } @@ -229,6 +249,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +default+ "default" } { +null+ "null" } { +not-null+ "not null" } + { system-random-generator "" } + { secure-random-generator "" } + { random-generator "" } } ; M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; @@ -244,6 +267,9 @@ M: sqlite-db type-table ( -- assoc ) { +native-id+ "integer primary key" } { +random-id+ "integer primary key" } { INTEGER "integer" } + { BIG-INTEGER "bigint" } + { SIGNED-BIG-INTEGER "bigint" } + { UNSIGNED-BIG-INTEGER "bigint" } { TEXT "text" } { VARCHAR "text" } { DATE "date" } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 56e401d5ec..083cf059c9 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.tuples +USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges -prettyprint tools.walker db.sqlite calendar -math.intervals db.postgresql ; +prettyprint tools.walker db.sqlite calendar sequences +math.intervals db.postgresql accessors random math.bitfields.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -290,8 +290,37 @@ TUPLE: exam id name score ; [ test-intervals ] test-sqlite -: test-ranges - ; +TUPLE: bignum-test id m n o ; +: ( m n o -- obj ) + bignum-test new + swap >>o + swap >>n + swap >>m ; + +: test-bignum + bignum-test "BIGNUM_TEST" + { + { "id" "ID" +native-id+ } + { "m" "M" BIG-INTEGER } + { "n" "N" UNSIGNED-BIG-INTEGER } + { "o" "O" SIGNED-BIG-INTEGER } + } define-persistent + [ bignum-test drop-table ] ignore-errors + [ ] [ bignum-test ensure-table ] unit-test + [ ] [ 63 2^ dup dup insert-tuple ] unit-test + + [ T{ bignum-test f 1 + -9223372036854775808 9223372036854775808 -9223372036854775808 } ] + [ T{ bignum-test f 1 } select-tuple ] unit-test ; + +[ test-bignum ] test-sqlite + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite TUPLE: secret n message ; C: secret @@ -299,14 +328,26 @@ C: secret : test-random-id secret "SECRET" { - { "n" "ID" +random-id+ } + { "n" "ID" +random-id+ system-random-generator } { "message" "MESSAGE" TEXT } } define-persistent [ ] [ secret ensure-table ] unit-test + [ ] [ f "kilroy was here" insert-tuple ] unit-test - [ ] [ T{ secret } select-tuples ] unit-test - ; + + [ ] [ f "kilroy was here2" insert-tuple ] unit-test + + [ ] [ f "kilroy was here3" insert-tuple ] unit-test + + [ t ] [ + T{ secret } select-tuples + first message>> "kilroy was here" head? + ] unit-test + + [ t ] [ + T{ secret } select-tuples length 3 = + ] unit-test ; [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 32431b4ddc..e0b4fce2f3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,9 +13,16 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -: db-table ( class -- obj ) "db-table" word-prop ; -: db-columns ( class -- obj ) "db-columns" word-prop ; -: db-relations ( class -- obj ) "db-relations" word-prop ; +ERROR: not-persistent ; + +: db-table ( class -- obj ) + "db-table" word-prop [ not-persistent ] unless* ; + +: db-columns ( class -- obj ) + "db-columns" word-prop ; + +: db-relations ( class -- obj ) + "db-relations" word-prop ; : set-primary-key ( key tuple -- ) [ @@ -61,7 +68,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) ] curry 2each ; : sql-props ( class -- columns table ) - dup db-columns swap db-table ; + [ db-columns ] [ db-table ] bi ; : with-disposals ( seq quot -- ) over sequence? [ @@ -88,17 +95,13 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] 2keep insert-tuple* ; : insert-nonnative ( tuple -- ) -! TODO logic here for unique ids dup class db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key nonnative-id? [ - insert-nonnative - ] [ - insert-native - ] if ; + dup class db-columns find-primary-key nonnative-id? + [ insert-nonnative ] [ insert-native ] if ; : update-tuple ( tuple -- ) dup class diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9959e894a7..b8855ce296 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -classes.singleton ; +classes.singleton accessors quotations random ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -12,12 +12,16 @@ HOOK: compound-modifier db ( str seq -- hash ) HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) +HOOK: random-id-quot db ( -- quot ) -TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; TUPLE: literal-bind key type value ; C: literal-bind +TUPLE: generator-bind key quot type retries ; +C: generator-bind + SINGLETON: +native-id+ SINGLETON: +assigned-id+ SINGLETON: +random-id+ @@ -27,6 +31,15 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; +: find-random-generator ( seq -- obj ) + [ + { + random-generator + system-random-generator + secure-random-generator + } member? + ] find nip [ system-random-generator ] unless* ; + : primary-key? ( spec -- ? ) sql-spec-primary-key +primary-key+? ; @@ -51,26 +64,27 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR -DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; +: handle-random-id ( statement -- ) + dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ + retryable >>type + random-id-quot >>quot + ] when drop ; + +SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB +FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) - [ ?first3 ] keep 3 ?tail* - { - set-sql-spec-class - set-sql-spec-slot-name - set-sql-spec-column-name - set-sql-spec-type - set-sql-spec-modifiers - } sql-spec construct + 3 f pad-right + [ first3 ] keep 3 tail + sql-spec new + swap >>modifiers + swap >>type + swap >>column-name + swap >>slot-name + swap >>class dup normalize-spec ; -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -TUPLE: no-sql-modifier ; -: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; - : number>string* ( n/str -- str ) dup number? [ number>string ] when ; @@ -88,13 +102,15 @@ TUPLE: no-sql-modifier ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html +ERROR: unknown-modifier ; + : lookup-modifier ( obj -- str ) - dup array? [ - unclip lookup-modifier swap compound-modifier - ] [ - modifier-table at* - [ "unknown modifier" throw ] unless - ] if ; + { + { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] } + [ modifier-table at* [ unknown-modifier ] unless ] + } cond ; + +ERROR: no-sql-type ; : lookup-type* ( obj -- str ) dup array? [ From 9b5351e81f4b6b4e46da33aedaae748be135b10a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:28:25 -0500 Subject: [PATCH 042/220] remove extra using --- extra/db/sqlite/sqlite.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 5f8247f67b..093a705b0d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -7,7 +7,6 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random math.bitfields.lib ; -USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -134,7 +133,6 @@ M: sqlite-db ( tuple -- statement ) ") values(" 0% [ ", " 0% ] [ dup type>> +random-id+ = [ -break dup modifiers>> find-random-generator [ [ From 0ae748d9bac879944abbc9c3172393c379860b9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 20:39:58 -0500 Subject: [PATCH 043/220] Compiler fixes --- core/compiler/tests/simple.factor | 10 +++- core/cpu/x86/allot/allot.factor | 2 +- core/inference/class/class.factor | 9 ++-- core/optimizer/backend/backend.factor | 66 +++++++++++++-------------- core/optimizer/optimizer-tests.factor | 2 +- 5 files changed, 47 insertions(+), 42 deletions(-) diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index dce2ec562a..bc9c56864c 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,6 +1,6 @@ USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings -alien arrays memory ; +alien arrays memory vocabs parser ; IN: compiler.tests ! Test empty word @@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ; ! Regression [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test + +! Regression +10 [ + [ "compiler.tests.foo" forget-vocab ] with-compilation-unit + [ t ] [ + "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval + ] unit-test +] times diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index bfcede7ef7..63870f94cd 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -29,7 +29,7 @@ IN: cpu.x86.allot allot-reg POP allot-reg cell [+] swap 8 align ADD ; -M: x86.32 %gc ( -- ) +M: x86 %gc ( -- ) "end" define-label temp-reg-1 load-zone-ptr temp-reg-2 temp-reg-1 cell [+] MOV diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index c2629f107f..2bc260593c 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -325,16 +325,15 @@ M: #call-label infer-classes-before ( #call-label -- ) [ set-value-class* ] 2each ; M: #return infer-classes-around + dup call-next-method nested-labels get length 0 > [ dup param>> nested-labels get peek param>> eq? [ [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri - classes= [ - drop - ] [ + classes= not [ fixed-point? off [ in-d>> value-classes get extract-keys ] keep set-node-classes - ] if + ] [ drop ] if ] [ drop ] if ] [ drop ] if ; @@ -369,5 +368,5 @@ M: object infer-classes-around : infer-classes/node ( node existing -- ) #! Infer classes, using the existing node's class info as a #! starting point. - [ node-classes ] [ node-literals ] [ node-intervals ] tri + [ classes>> ] [ literals>> ] [ intervals>> ] tri infer-classes-with ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 3237f095bf..9630f9dc70 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -3,7 +3,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes optimizer.def-use ; +combinators classes optimizer.def-use accessors ; IN: optimizer.backend SYMBOL: class-substitutions @@ -16,37 +16,32 @@ SYMBOL: optimizer-changed GENERIC: optimize-node* ( node -- node/t changed? ) -: ?union ( assoc/f assoc -- hash ) - over [ assoc-union ] [ nip ] if ; +: ?union ( assoc assoc/f -- assoc' ) + dup assoc-empty? [ drop ] [ swap assoc-union ] if ; -: add-node-literals ( assoc node -- ) - over assoc-empty? [ +: add-node-literals ( node assoc -- ) + [ ?union ] curry change-literals drop ; + +: add-node-classes ( node assoc -- ) + [ ?union ] curry change-classes drop ; + +: substitute-values ( node assoc -- ) + dup assoc-empty? [ 2drop ] [ - [ node-literals ?union ] keep set-node-literals - ] if ; - -: add-node-classes ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - [ node-classes ?union ] keep set-node-classes - ] if ; - -: substitute-values ( assoc node -- ) - over assoc-empty? [ - 2drop - ] [ - 2dup node-in-d swap substitute-here - 2dup node-in-r swap substitute-here - 2dup node-out-d swap substitute-here - node-out-r swap substitute-here + { + [ >r in-d>> r> substitute-here ] + [ >r in-r>> r> substitute-here ] + [ >r out-d>> r> substitute-here ] + [ >r out-r>> r> substitute-here ] + } 2cleave ] if ; : perform-substitutions ( node -- ) - class-substitutions get over add-node-classes - literal-substitutions get over add-node-literals - value-substitutions get swap substitute-values ; + [ class-substitutions get add-node-classes ] + [ literal-substitutions get add-node-literals ] + [ value-substitutions get substitute-values ] + tri ; DEFER: optimize-nodes @@ -90,18 +85,21 @@ M: node optimize-node* drop t f ; #! Not very efficient. dupd union* update ; -: compute-value-substitutions ( #return/#values #call/#merge -- assoc ) - node-out-d swap node-in-d 2array unify-lengths flip +: compute-value-substitutions ( #call/#merge #return/#values -- assoc ) + [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip [ = not ] assoc-subset >hashtable ; : cleanup-inlining ( #return/#values -- newnode changed? ) - dup node-successor dup [ - class-substitutions get pick node-classes update - literal-substitutions get pick node-literals update - tuck compute-value-substitutions value-substitutions get swap update* - node-successor t + dup node-successor [ + [ node-successor ] keep + { + [ nip classes>> class-substitutions get swap update ] + [ nip literals>> literal-substitutions get swap update ] + [ compute-value-substitutions value-substitutions get swap update* ] + [ drop node-successor ] + } 2cleave t ] [ - 2drop t f + drop t f ] if ; ! #return diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 63a63a2f92..14dcd62c61 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -291,7 +291,6 @@ TUPLE: silly-tuple a b ; [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test -! Make sure we don't lose GENERIC: generic-inline-test ( x -- y ) M: integer generic-inline-test ; @@ -308,6 +307,7 @@ M: integer generic-inline-test ; generic-inline-test generic-inline-test ; +! Inlining all of the above should only take two passes [ { t f } ] [ \ generic-inline-test-1 word-def dataflow [ optimize-1 , optimize-1 , drop ] { } make From 4ce7ddb27d416e5eeadc8487f24f116f0a6644c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 20:40:04 -0500 Subject: [PATCH 044/220] Cleanup --- extra/ui/commands/commands.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index 90eb6254cd..c7db687dc3 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -66,7 +66,7 @@ M: word command-description ( word -- str ) H{ { +nullary+ f } { +listener+ f } { +description+ f } } ; : define-command ( word hash -- ) - default-flags swap assoc-union >r word-props r> update ; + [ word-props ] [ default-flags swap assoc-union ] bi* update ; : command-quot ( target command -- quot ) dup 1quotation swap +nullary+ word-prop From f4fdbd6a6cb744b383a1e85b1f351a691ab568a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 20:56:36 -0500 Subject: [PATCH 045/220] Fix problem with words becoming uncompiled --- core/generator/generator.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4eb2c0fe4e..390dc28d8e 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -40,16 +40,16 @@ SYMBOL: current-label-start compiled-stack-traces? compiling-word get f ? 1vector literal-table set - f compiling-word get compiled get set-at ; + f compiling-label get compiled get set-at ; -: finish-compiling ( literals relocation labels code -- ) +: save-machine-code ( literals relocation labels code -- ) 4array compiling-label get compiled get set-at ; : with-generator ( node word label quot -- ) [ >r begin-compiling r> { } make fixup - finish-compiling + save-machine-code ] with-scope ; inline GENERIC: generate-node ( node -- next ) From 6a3f908c41b8cb249d9e6f285e3faadcfa1ded0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 21:41:51 -0500 Subject: [PATCH 046/220] Fix PowerPC inline allocators --- core/cpu/ppc/allot/allot.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 47dc6b1570..49c77c65ed 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel cpu.ppc.architecture cpu.ppc.assembler kernel.private namespaces math sequences generic arrays @@ -7,7 +7,7 @@ cpu.architecture alien ; IN: cpu.ppc.allot : load-zone-ptr ( reg -- ) - "nursery" f pick %load-dlsym ; + >r "nursery" f r> %load-dlsym ; : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the @@ -30,8 +30,8 @@ M: ppc %gc 12 load-zone-ptr 11 12 cell LWZ ! nursery.here -> r11 12 12 3 cells LWZ ! nursery.end -> r12 - 11 12 1024 ADDI ! add ALLOT_BUFFER_ZONE to here - 0 11 12 CMPI ! is here >= end? + 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + 11 0 12 CMP ! is here >= end? "end" get BLE 0 frame-required %prepare-alien-invoke From 435e24f3b735edfc9980aa435dd08cc49a96741e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 21:43:45 -0500 Subject: [PATCH 047/220] Fix regression --- core/inference/class/class.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 2bc260593c..6d5b708f34 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -325,7 +325,6 @@ M: #call-label infer-classes-before ( #call-label -- ) [ set-value-class* ] 2each ; M: #return infer-classes-around - dup call-next-method nested-labels get length 0 > [ dup param>> nested-labels get peek param>> eq? [ [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri @@ -334,8 +333,8 @@ M: #return infer-classes-around [ in-d>> value-classes get extract-keys ] keep set-node-classes ] [ drop ] if - ] [ drop ] if - ] [ drop ] if ; + ] [ call-next-method ] if + ] [ call-next-method ] if ; M: object infer-classes-around { From 896c920d85008304c9896ca0daf46e91b9faadea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 22:09:36 -0500 Subject: [PATCH 048/220] retryable statements actually retry now --- extra/db/db.factor | 15 +----------- extra/db/sqlite/ffi/ffi.factor | 3 ++- extra/db/sqlite/lib/lib.factor | 4 +++- extra/db/sqlite/sqlite.factor | 24 ++++++++++++------- extra/db/tuples/tuples-tests.factor | 2 +- extra/db/tuples/tuples.factor | 36 ++++++++++++++++++++++++++++- extra/db/types/types.factor | 8 +------ 7 files changed, 59 insertions(+), 33 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index ce6232f414..82193ed467 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -42,7 +42,6 @@ TUPLE: prepared-statement < statement ; SINGLETON: throwable SINGLETON: nonthrowable -SINGLETON: retryable : make-throwable ( obj -- obj' ) dup sequence? [ @@ -58,13 +57,6 @@ SINGLETON: retryable nonthrowable >>type ] if ; -: make-retryable ( obj quot -- obj' ) - over sequence? [ - [ make-retryable ] curry map - ] [ - retryable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) @@ -78,6 +70,7 @@ HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) +GENERIC: low-level-bind ( statement -- ) GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) @@ -95,12 +88,6 @@ M: throwable execute-statement* ( statement type -- ) M: nonthrowable execute-statement* ( statement type -- ) drop [ query-results dispose ] [ 2drop ] recover ; -M: retryable execute-statement* ( statement type -- ) - [ - dup dup quot>> call - [ query-results dispose ] [ 2drop ] recover - ] curry 10 retry ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 6b94c02c65..4b5a019fca 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -108,7 +108,7 @@ LIBRARY: sqlite FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; @@ -123,6 +123,7 @@ FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; +FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 61070b078b..b6078fc983 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -33,7 +33,7 @@ IN: db.sqlite.lib : sqlite-prepare ( db sql -- handle ) dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; : sqlite-bind-parameter-index ( handle name -- index ) @@ -114,6 +114,8 @@ IN: db.sqlite.lib : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-clear-bindings ( handle -- ) + sqlite3_clear_bindings sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; : sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-name ( handle index -- string ) sqlite3_column_name ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 093a705b0d..6dc394abd9 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -7,6 +7,7 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random math.bitfields.lib ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -43,17 +44,21 @@ M: sqlite-statement dispose ( statement -- ) M: sqlite-result-set dispose ( result-set -- ) f >>handle drop ; -: sqlite-bind ( triples handle -- ) - swap [ first3 sqlite-bind-type ] with each ; - : reset-statement ( statement -- ) sqlite-maybe-prepare handle>> sqlite-reset ; +: reset-bindings ( statement -- ) + sqlite-maybe-prepare + handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; + +M: sqlite-statement low-level-bind ( statement -- ) + [ statement-bind-params ] [ statement-handle ] bi + swap [ first3 sqlite-bind-type ] with each ; + M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare - dup statement-bound? [ dup reset-statement ] when - [ statement-bind-params ] [ statement-handle ] bi - sqlite-bind ; + dup statement-bound? [ dup reset-bindings ] when + low-level-bind ; GENERIC: sqlite-bind-conversion ( tuple obj -- array ) @@ -140,13 +145,16 @@ M: sqlite-db ( tuple -- statement ) dup 0% random-id-quot ] with-random ] curry - [ type>> ] bi 10 1, + [ type>> ] bi 1, ] [ bind% ] if ] interleave ");" 0% - ] sqlite-make ; + ] sqlite-make + dup in-params>> [ generator-bind? ] contains? [ + make-retryable + ] when ; M: sqlite-db ( tuple -- statement ) ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 083cf059c9..2eb31ebe18 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -346,7 +346,7 @@ C: secret ] unit-test [ t ] [ - T{ secret } select-tuples length 3 = + T{ secret } select-tuples dup . length 3 = ] unit-test ; [ test-random-id ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e0b4fce2f3..1b1e48ddee 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -classes.tuple words sequences slots math +classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples @@ -49,6 +49,40 @@ HOOK: db ( tuple class -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) +SINGLETON: retryable + +: make-retryable ( obj -- obj' ) + dup sequence? [ + [ make-retryable ] map + ] [ + retryable >>type + ] if ; + +: regenerate-params ( statement -- statement ) + dup + [ bind-params>> ] [ in-params>> ] bi + [ + dup generator-bind? [ + quot>> call over set-second + ] [ + drop + ] if + ] 2map >>bind-params ; + +: handle-random-id ( statement -- ) + dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ + retryable >>type + random-id-quot >>quot + ] when drop ; + +M: retryable execute-statement* ( statement type -- ) + drop + [ + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry 10 retry drop ; + : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class new [ [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b8855ce296..9f111a42e4 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -19,7 +19,7 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; TUPLE: literal-bind key type value ; C: literal-bind -TUPLE: generator-bind key quot type retries ; +TUPLE: generator-bind key quot type ; C: generator-bind SINGLETON: +native-id+ @@ -64,12 +64,6 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -: handle-random-id ( statement -- ) - dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ - retryable >>type - random-id-quot >>quot - ] when drop ; - SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; From 18c2f11d0603940472a0babcdab30c0d73934106 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 22:56:28 -0500 Subject: [PATCH 049/220] Move columns, bit-vectors, byte-vectors, float-vectors to extra --- core/prettyprint/backend/backend.factor | 14 +++----- core/sequences/sequences-docs.factor | 22 +------------ core/sequences/sequences-tests.factor | 7 ---- core/sequences/sequences.factor | 14 +------- core/syntax/syntax-docs.factor | 33 ------------------- core/syntax/syntax.factor | 3 -- extra/benchmark/dispatch2/dispatch2.factor | 2 +- extra/benchmark/dispatch3/dispatch3.factor | 2 +- .../spectral-norm/spectral-norm.factor | 4 +-- .../bit-vectors/bit-vectors-docs.factor | 9 +++++ .../bit-vectors/bit-vectors-tests.factor | 0 .../bit-vectors/bit-vectors.factor | 7 +++- {core => extra}/bit-vectors/summary.txt | 0 {core => extra}/bit-vectors/tags.txt | 0 .../byte-vectors/byte-vectors-docs.factor | 10 +++++- .../byte-vectors/byte-vectors-tests.factor | 0 .../byte-vectors/byte-vectors.factor | 7 +++- {core => extra}/byte-vectors/summary.txt | 0 {core => extra}/byte-vectors/tags.txt | 0 .../float-vectors/float-vectors-docs.factor | 8 +++++ .../float-vectors/float-vectors-tests.factor | 0 .../float-vectors/float-vectors.factor | 7 +++- {core => extra}/float-vectors/summary.txt | 0 {core => extra}/float-vectors/tags.txt | 0 extra/help/handbook/handbook.factor | 6 ++-- extra/help/help.factor | 2 +- extra/math/fft/fft.factor | 2 +- extra/math/haar/haar.factor | 2 +- extra/sudoku/sudoku.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- 31 files changed, 64 insertions(+), 103 deletions(-) rename {core => extra}/bit-vectors/bit-vectors-docs.factor (82%) rename {core => extra}/bit-vectors/bit-vectors-tests.factor (100%) rename {core => extra}/bit-vectors/bit-vectors.factor (79%) rename {core => extra}/bit-vectors/summary.txt (100%) rename {core => extra}/bit-vectors/tags.txt (100%) rename {core => extra}/byte-vectors/byte-vectors-docs.factor (79%) rename {core => extra}/byte-vectors/byte-vectors-tests.factor (100%) rename {core => extra}/byte-vectors/byte-vectors.factor (79%) rename {core => extra}/byte-vectors/summary.txt (100%) rename {core => extra}/byte-vectors/tags.txt (100%) rename {core => extra}/float-vectors/float-vectors-docs.factor (83%) rename {core => extra}/float-vectors/float-vectors-tests.factor (100%) rename {core => extra}/float-vectors/float-vectors.factor (80%) rename {core => extra}/float-vectors/summary.txt (100%) rename {core => extra}/float-vectors/tags.txt (100%) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index c9019b029d..7ae03443a7 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors -generic hashtables io assocs kernel math namespaces sequences -strings sbufs io.styles vectors words prettyprint.config -prettyprint.sections quotations io io.files math.parser effects -classes.tuple classes.tuple.private classes float-arrays -float-vectors ; +USING: arrays byte-arrays bit-arrays generic hashtables io +assocs kernel math namespaces sequences strings sbufs io.styles +vectors words prettyprint.config prettyprint.sections quotations +io io.files math.parser effects classes.tuple +classes.tuple.private classes float-arrays ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -140,11 +139,8 @@ M: curry pprint-delims drop \ [ \ ] ; M: compose pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; -M: byte-vector pprint-delims drop \ BV{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ; -M: bit-vector pprint-delims drop \ ?V{ \ } ; M: float-array pprint-delims drop \ F{ \ } ; -M: float-vector pprint-delims drop \ FV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index bb3dc9337e..0dea0f43d9 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences" { $subsection reversed } { $subsection } "Transposing a matrix:" -{ $subsection flip } -"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" -{ $subsection column } -{ $subsection } ; +{ $subsection flip } ; ARTICLE: "sequences-appending" "Appending sequences" { $subsection append } @@ -785,23 +782,6 @@ HELP: { subseq } related-words -HELP: column -{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; - -HELP: ( seq n -- column ) -{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } -{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } -{ $examples - { $example - "USING: arrays prettyprint sequences ;" - "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." - "{ 1 4 7 }" - } -} -{ $notes - "In the same sense that " { $link } " is a virtual variant of " { $link reverse } ", " { $link } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "." -} ; - HELP: repetition { $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link } "." } ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e8db18b3d0..100184798c 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -224,13 +224,6 @@ unit-test [ V{ 1 2 3 } ] [ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test -! Columns -{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set - -[ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test -[ ] [ "seq" get 1 [ sq ] change-each ] unit-test -[ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test - ! erg's random tester found this one [ SBUF" 12341234" ] [ 9 dup "1234" swap push-all dup dup swap push-all diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 252df54391..924d9a05cb 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -215,18 +215,6 @@ M: slice length dup slice-to swap slice-from - ; INSTANCE: slice virtual-sequence -! A column of a matrix -TUPLE: column seq col ; - -C: column - -M: column virtual-seq column-seq ; -M: column virtual@ - dup column-col -rot column-seq nth bounds-check ; -M: column length column-seq length ; - -INSTANCE: column virtual-sequence - ! One element repeated many times TUPLE: repetition len elt ; @@ -703,5 +691,5 @@ PRIVATE> : flip ( matrix -- newmatrix ) dup empty? [ dup [ length ] map infimum - [ dup like ] with map + swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as ] unless ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c2eb411f0a..a2d15d2981 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -150,18 +150,6 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax" { $subsection POSTPONE: B{ } "Byte arrays are documented in " { $link "byte-arrays" } "." ; -ARTICLE: "syntax-bit-vectors" "Bit vector syntax" -{ $subsection POSTPONE: ?V{ } -"Bit vectors are documented in " { $link "bit-vectors" } "." ; - -ARTICLE: "syntax-float-vectors" "Float vector syntax" -{ $subsection POSTPONE: FV{ } -"Float vectors are documented in " { $link "float-vectors" } "." ; - -ARTICLE: "syntax-byte-vectors" "Byte vector syntax" -{ $subsection POSTPONE: BV{ } -"Byte vectors are documented in " { $link "byte-vectors" } "." ; - ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "pathnames" } "." ; @@ -182,9 +170,6 @@ $nl { $subsection "syntax-float-arrays" } { $subsection "syntax-vectors" } { $subsection "syntax-sbufs" } -{ $subsection "syntax-bit-vectors" } -{ $subsection "syntax-byte-vectors" } -{ $subsection "syntax-float-vectors" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } { $subsection "syntax-pathnames" } ; @@ -291,30 +276,12 @@ HELP: B{ { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "B{ 1 2 3 }" } } ; -HELP: BV{ -{ $syntax "BV{ elements... }" } -{ $values { "elements" "a list of bytes" } } -{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "BV{ 1 2 3 12 }" } } ; - HELP: ?{ { $syntax "?{ elements... }" } { $values { "elements" "a list of booleans" } } { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "?{ t f t }" } } ; -HELP: ?V{ -{ $syntax "?V{ elements... }" } -{ $values { "elements" "a list of booleans" } } -{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "?V{ t f t }" } } ; - -HELP: FV{ -{ $syntax "FV{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; - HELP: F{ { $syntax "F{ elements... }" } { $values { "elements" "a list of real numbers" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index eaf5ffea05..f6252a3e16 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -79,11 +79,8 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax - "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax - "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax - "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index d51a723cbd..53e9c9a14c 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,4 +1,4 @@ -USING: namespaces math sequences splitting kernel ; +USING: namespaces math sequences splitting kernel columns ; IN: benchmark.dispatch2 : sequences diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index bb4c5ba904..409d6d4a0f 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,5 +1,5 @@ USING: sequences math mirrors splitting kernel namespaces -assocs alien.syntax ; +assocs alien.syntax columns ; IN: benchmark.dispatch3 GENERIC: g ( obj -- str ) diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 7eddeefc1b..2c7dc1e80d 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -19,7 +19,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-A-times-u) r> + ] reduce nip - ] F{ } map-as 2nip ; inline + ] F{ } map-as { float-array } declare 2nip ; inline : (eval-At-times-u) ( u i j -- x ) tuck swap eval-A >r swap nth-unsafe r> * ; inline @@ -29,7 +29,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-At-times-u) r> + ] reduce nip - ] F{ } map-as 2nip ; inline + ] F{ } map-as { float-array } declare 2nip ; inline : eval-AtA-times-u ( n u -- seq ) dupd eval-A-times-u eval-At-times-u ; inline diff --git a/core/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor similarity index 82% rename from core/bit-vectors/bit-vectors-docs.factor rename to extra/bit-vectors/bit-vectors-docs.factor index f2f5c4da2c..9ceb2df342 100755 --- a/core/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -11,6 +11,8 @@ $nl "Creating bit vectors:" { $subsection >bit-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: ?V{ } "If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:" { $code "?V{ } clone" } ; @@ -31,3 +33,10 @@ HELP: bit-array>vector { $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } } { $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; + +HELP: ?V{ +{ $syntax "?V{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?V{ t f t }" } } ; + diff --git a/core/bit-vectors/bit-vectors-tests.factor b/extra/bit-vectors/bit-vectors-tests.factor similarity index 100% rename from core/bit-vectors/bit-vectors-tests.factor rename to extra/bit-vectors/bit-vectors-tests.factor diff --git a/core/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor similarity index 79% rename from core/bit-vectors/bit-vectors.factor rename to extra/bit-vectors/bit-vectors.factor index db941ac6f7..a6e8ebe90a 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable bit-arrays ; +sequences.private growable bit-arrays prettyprint.backend +parser ; IN: bit-vectors ; INSTANCE: bit-vector growable + +: ?V \ } [ >bit-vector ] parse-literal ; parsing + +M: bit-vector pprint-delims drop \ ?V{ \ } ; diff --git a/core/bit-vectors/summary.txt b/extra/bit-vectors/summary.txt similarity index 100% rename from core/bit-vectors/summary.txt rename to extra/bit-vectors/summary.txt diff --git a/core/bit-vectors/tags.txt b/extra/bit-vectors/tags.txt similarity index 100% rename from core/bit-vectors/tags.txt rename to extra/bit-vectors/tags.txt diff --git a/core/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor similarity index 79% rename from core/byte-vectors/byte-vectors-docs.factor rename to extra/byte-vectors/byte-vectors-docs.factor index 0f1054ee5e..f34bc20219 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/extra/byte-vectors/byte-vectors-docs.factor @@ -3,7 +3,7 @@ byte-vectors.private combinators ; IN: byte-vectors ARTICLE: "byte-vectors" "Byte vectors" -"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." +"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." $nl "Byte vectors form a class:" { $subsection byte-vector } @@ -11,6 +11,8 @@ $nl "Creating byte vectors:" { $subsection >byte-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: BV{ } "If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" { $code "BV{ } clone" } ; @@ -32,3 +34,9 @@ HELP: byte-array>vector { $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } } { $description "Creates a new byte vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ; + +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/extra/byte-vectors/byte-vectors-tests.factor similarity index 100% rename from core/byte-vectors/byte-vectors-tests.factor rename to extra/byte-vectors/byte-vectors-tests.factor diff --git a/core/byte-vectors/byte-vectors.factor b/extra/byte-vectors/byte-vectors.factor similarity index 79% rename from core/byte-vectors/byte-vectors.factor rename to extra/byte-vectors/byte-vectors.factor index 206a23f43b..4d998bdfd6 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/extra/byte-vectors/byte-vectors.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable byte-arrays ; +sequences.private growable byte-arrays prettyprint.backend +parser ; IN: byte-vectors ; INSTANCE: byte-vector growable + +: BV{ \ } [ >byte-vector ] parse-literal ; parsing + +M: byte-vector pprint-delims drop \ BV{ \ } ; diff --git a/core/byte-vectors/summary.txt b/extra/byte-vectors/summary.txt similarity index 100% rename from core/byte-vectors/summary.txt rename to extra/byte-vectors/summary.txt diff --git a/core/byte-vectors/tags.txt b/extra/byte-vectors/tags.txt similarity index 100% rename from core/byte-vectors/tags.txt rename to extra/byte-vectors/tags.txt diff --git a/core/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor similarity index 83% rename from core/float-vectors/float-vectors-docs.factor rename to extra/float-vectors/float-vectors-docs.factor index ef0645a0af..8d25da54be 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/extra/float-vectors/float-vectors-docs.factor @@ -11,6 +11,8 @@ $nl "Creating float vectors:" { $subsection >float-vector } { $subsection } +"Literal syntax:" +{ $subsection POSTPONE: FV{ } "If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" { $code "FV{ } clone" } ; @@ -32,3 +34,9 @@ HELP: float-array>vector { $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } } { $description "Creates a new float vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ; + +HELP: FV{ +{ $syntax "FV{ elements... }" } +{ $values { "elements" "a list of real numbers" } } +{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; diff --git a/core/float-vectors/float-vectors-tests.factor b/extra/float-vectors/float-vectors-tests.factor similarity index 100% rename from core/float-vectors/float-vectors-tests.factor rename to extra/float-vectors/float-vectors-tests.factor diff --git a/core/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor similarity index 80% rename from core/float-vectors/float-vectors.factor rename to extra/float-vectors/float-vectors.factor index 7f62f6f95c..f3f6b12090 100755 --- a/core/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable float-arrays ; +sequences.private growable float-arrays prettyprint.backend +parser ; IN: float-vectors ; INSTANCE: float-vector growable + +: FV{ \ } [ >float-vector ] parse-literal ; parsing + +M: float-vector pprint-delims drop \ FV{ \ } ; diff --git a/core/float-vectors/summary.txt b/extra/float-vectors/summary.txt similarity index 100% rename from core/float-vectors/summary.txt rename to extra/float-vectors/summary.txt diff --git a/core/float-vectors/tags.txt b/extra/float-vectors/tags.txt similarity index 100% rename from core/float-vectors/tags.txt rename to extra/float-vectors/tags.txt diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 4e6bfe4888..d5bc1875e4 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -145,9 +145,9 @@ ARTICLE: "collections" "Collections" { $subsection "vectors" } "Resizable specialized sequences:" { $subsection "sbufs" } -{ $subsection "bit-vectors" } -{ $subsection "byte-vectors" } -{ $subsection "float-vectors" } +{ $vocab-subsection "Bit vectors" "bit-vectors" } +{ $vocab-subsection "Byte vectors" "byte-vectors" } +{ $vocab-subsection "Float vectors" "float-vectors" } { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } diff --git a/extra/help/help.factor b/extra/help/help.factor index aa2704a799..e0b2709932 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -38,7 +38,7 @@ M: predicate word-help* drop \ $predicate ; \ $error-description swap word-help elements empty? not ; : sort-articles ( seq -- newseq ) - [ dup article-title ] { } map>assoc sort-values 0 ; + [ dup article-title ] { } map>assoc sort-values keys ; : all-errors ( -- seq ) all-words [ error? ] subset sort-articles ; diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor index 625be534ce..4d4068158e 100644 --- a/extra/math/fft/fft.factor +++ b/extra/math/fft/fft.factor @@ -1,7 +1,7 @@ ! Fast Fourier Transform, copyright (C) 2007 Hans Schmid ! http://dressguardmeister.blogspot.com/2007/01/fft.html USING: arrays sequences math math.vectors math.constants -math.functions kernel splitting ; +math.functions kernel splitting columns ; IN: math.fft : n^v ( n v -- w ) [ ^ ] with map ; diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index 91d9fd8ece..9254fd0ce7 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -1,5 +1,5 @@ ! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/ -USING: sequences math kernel splitting ; +USING: sequences math kernel splitting columns ; IN: math.haar : averages ( seq -- seq ) diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index b0ba85c97f..1cb82253b1 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -1,6 +1,6 @@ ! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html USING: sequences namespaces kernel math math.parser io -io.styles combinators ; +io.styles combinators columns ; IN: sudoku SYMBOL: solutions diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index 342c360c83..9951256249 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences words io -io.streams.string math.vectors ui.gadgets ; +io.streams.string math.vectors ui.gadgets columns ; IN: ui.gadgets.grids TUPLE: grid children gap fill? ; diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index f68a70c2bd..ed0f38b743 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -3,7 +3,7 @@ USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors classes.tuple classes ui.gadgets boxes -calendar alarms symbols combinators sets ; +calendar alarms symbols combinators sets columns ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; From 4184a3ce549e1c21a8889d22ae77d4a5deff7edd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:18:12 -0500 Subject: [PATCH 050/220] partial conversion of postgres --- extra/db/postgresql/lib/lib.factor | 10 ++++++-- extra/db/postgresql/postgresql.factor | 35 ++++++++++++++++----------- extra/db/sqlite/sqlite.factor | 15 +++++++----- extra/db/tuples/tuples-tests.factor | 4 ++- extra/db/types/types.factor | 3 +-- 5 files changed, 42 insertions(+), 25 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bfe7dab3ce..cd3d619326 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary -io.streams.byte-array ; +io.streams.byte-array inspector ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -28,7 +28,13 @@ IN: db.postgresql.lib : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; -: postgresql-result-ok? ( n -- ? ) +ERROR: postgresql-result-null ; + +M: postgresql-result-null summary ( obj -- str ) + drop "PQexec returned f." ; + +: postgresql-result-ok? ( res -- ? ) + [ postgresql-result-null ] unless* PQresultStatus PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 9dfa123952..d0eb390888 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors ; +namespaces.lib accessors random ; IN: db.postgresql TUPLE: postgresql-db < db @@ -43,10 +43,9 @@ M: postgresql-statement bind-statement* ( statement -- ) drop ; M: postgresql-statement bind-tuple ( tuple statement -- ) - [ - statement-in-params - [ sql-spec-slot-name swap get-slot-named ] with map - ] keep set-statement-bind-params ; + tuck in-params>> + [ slot-name>> swap get-slot-named ] with map + >>bind-params drop ; M: postgresql-result-set #rows ( result-set -- n ) handle>> PQntuples ; @@ -55,11 +54,11 @@ M: postgresql-result-set #columns ( result-set -- n ) handle>> PQnfields ; M: postgresql-result-set row-column ( result-set column -- obj ) - >r dup result-set-handle swap result-set-n r> pq-get-string ; + >r [ handle>> ] [ n>> ] bi r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) dup pick result-set-out-params nth sql-spec-type - >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; + >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup statement-bind-params [ @@ -82,7 +81,7 @@ M: postgresql-statement dispose ( query -- ) f swap set-statement-handle ; M: postgresql-result-set dispose ( result-set -- ) - dup result-set-handle PQclear + dup handle>> PQclear 0 0 f roll { set-result-set-n set-result-set-max set-result-set-handle } set-slots ; @@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get handle>> "" r> - dup statement-sql swap statement-in-params + [ sql>> ] [ in-params>> ] bi length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -115,7 +114,10 @@ SYMBOL: postgresql-counter postgresql-counter [ inc ] keep get 0# ; M: postgresql-db bind% ( spec -- ) - 1, bind-name% ; + bind-name% 1, ; + +M: postgresql-db bind# ( spec obj -- ) + >r bind-name% f swap type>> r> 1, ; : postgresql-make ( class quot -- ) >r sql-props r> @@ -125,11 +127,10 @@ M: postgresql-db bind% ( spec -- ) : create-table-sql ( class -- statement ) [ "create table " 0% 0% - "(" 0% - [ ", " 0% ] [ - dup sql-spec-column-name 0% + "(" 0% [ ", " 0% ] [ + dup column-name>> 0% " " 0% - dup sql-spec-type t lookup-type 0% + dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% ] postgresql-make ; @@ -250,6 +251,7 @@ M: postgresql-db ( tuple class -- statement ) M: postgresql-db type-table ( -- hash ) H{ { +native-id+ "integer" } + { +random-id+ "bigint" } { TEXT "text" } { VARCHAR "varchar" } { INTEGER "integer" } @@ -265,6 +267,7 @@ M: postgresql-db type-table ( -- hash ) M: postgresql-db create-type-table ( -- hash ) H{ { +native-id+ "serial primary key" } + { +random-id+ "bigint primary key" } } ; : postgresql-compound ( str n -- newstr ) @@ -286,12 +289,16 @@ M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +random-id+ "primary key" } { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } { +null+ "null" } { +not-null+ "not null" } + { system-random-generator "" } + { secure-random-generator "" } + { random-generator "" } } ; M: postgresql-db compound-type ( str n -- newstr ) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 6dc394abd9..f361e18c48 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -110,10 +110,16 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; + +: maybe-make-retryable ( statement -- statement ) + dup in-params>> [ generator-bind? ] contains? [ + make-retryable + ] when ; + : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - ; + maybe-make-retryable ; M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -124,7 +130,7 @@ M: sqlite-db create-sql-statement ( class -- statement ) dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% - ] sqlite-make ; + ] sqlite-make dup sql>> . ; M: sqlite-db drop-sql-statement ( class -- statement ) [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; @@ -151,10 +157,7 @@ M: sqlite-db ( tuple -- statement ) ] if ] interleave ");" 0% - ] sqlite-make - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + ] sqlite-make ; M: sqlite-db ( tuple -- statement ) ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 2eb31ebe18..038197d864 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -346,13 +346,15 @@ C: secret ] unit-test [ t ] [ - T{ secret } select-tuples dup . length 3 = + T{ secret } select-tuples length 3 = ] unit-test ; [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-repeated-insert ] test-sqlite + +[ test-random-id ] test-postgresql [ native-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-repeated-insert ] test-postgresql diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9f111a42e4..41db970b12 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -110,8 +110,7 @@ ERROR: no-sql-type ; dup array? [ first lookup-type* ] [ - type-table at* - [ no-sql-type ] unless + type-table at* [ no-sql-type ] unless ] if ; : lookup-create-type ( obj -- str ) From 3be408184ce053ff31229cd0b693444ee220d4c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:41:48 -0500 Subject: [PATCH 051/220] remove most of the old setters --- extra/db/postgresql/lib/lib.factor | 36 +++++++--------- extra/db/postgresql/postgresql.factor | 60 ++++++++++++++------------- 2 files changed, 45 insertions(+), 51 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index cd3d619326..bb4c6872fb 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -23,7 +23,7 @@ IN: db.postgresql.lib "\n" split [ [ blank? ] trim ] map "\n" join ; : postgresql-error-message ( -- str ) - db get db-handle (postgresql-error-message) ; + db get handle>> (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; @@ -43,7 +43,7 @@ M: postgresql-result-null summary ( obj -- str ) dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) - db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ + db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw ] unless ; @@ -64,25 +64,19 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - statement-in-params - [ sql-spec-type type>oid ] map - >c-uint-array ; + in-params>> [ type>> type>oid ] map >c-uint-array ; : malloc-byte-array/length [ malloc-byte-array dup free-always ] [ length ] bi ; - : param-values ( statement -- seq seq2 ) - [ statement-bind-params ] - [ statement-in-params ] bi + [ bind-params>> ] [ in-params>> ] bi [ - sql-spec-type { + type>> { { FACTOR-BLOB [ - dup [ - object>bytes - malloc-byte-array/length ] [ 0 ] if ] } - { BLOB [ - dup [ malloc-byte-array/length ] [ 0 ] if ] } + dup [ object>bytes malloc-byte-array/length ] [ 0 ] if + ] } + { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } [ drop number>string* dup [ malloc-char-string dup free-always @@ -96,22 +90,20 @@ M: postgresql-result-null summary ( obj -- str ) ] if ; : param-formats ( statement -- seq ) - statement-in-params - [ sql-spec-type type>param-format ] map - >c-uint-array ; + in-params>> [ type>> type>param-format ] map >c-uint-array ; : do-postgresql-bound-statement ( statement -- res ) [ - >r db get db-handle r> + >r db get handle>> r> { - [ statement-sql ] - [ statement-bind-params length ] + [ sql>> ] + [ bind-params>> length ] [ param-types ] [ param-values ] [ param-formats ] } cleave 0 PQexecParams dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ] with-destructors ; @@ -120,7 +112,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue alien>char-string - dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index d0eb390888..f13bceddd3 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -57,11 +57,11 @@ M: postgresql-result-set row-column ( result-set column -- obj ) >r [ handle>> ] [ n>> ] bi r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) - dup pick result-set-out-params nth sql-spec-type - >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ; + dup pick out-params>> nth type>> + >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-bind-params [ + dup bind-params>> [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -71,27 +71,29 @@ M: postgresql-statement query-results ( query -- result-set ) dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) - dup result-set-n 1+ swap set-result-set-n ; + [ 1+ ] change-n drop ; M: postgresql-result-set more-rows? ( result-set -- ? ) - dup result-set-n swap result-set-max < ; + [ n>> ] [ max>> ] bi < ; M: postgresql-statement dispose ( query -- ) - dup statement-handle PQclear - f swap set-statement-handle ; + dup handle>> PQclear + f >>handle drop ; M: postgresql-result-set dispose ( result-set -- ) - dup handle>> PQclear - 0 0 f roll { - set-result-set-n set-result-set-max set-result-set-handle - } set-slots ; + [ handle>> PQclear ] + [ + 0 >>n + 0 >>max + f >>handle drop + ] bi ; M: postgresql-statement prepare-statement ( statement -- ) - [ - >r db get handle>> "" r> - [ sql>> ] [ in-params>> ] bi - length f PQprepare postgresql-error - ] keep set-statement-handle ; + dup + >r db get handle>> "" r> + [ sql>> ] [ in-params>> ] bi + length f PQprepare postgresql-error + >>handle drop ; M: postgresql-db ( sql in out -- statement ) ; @@ -111,7 +113,7 @@ M: postgresql-db rollback-transaction ( -- ) SYMBOL: postgresql-counter : bind-name% ( -- ) CHAR: $ 0, - postgresql-counter [ inc ] keep get 0# ; + postgresql-counter [ inc ] [ get 0# ] bi ; M: postgresql-db bind% ( spec -- ) bind-name% 1, ; @@ -142,7 +144,7 @@ M: postgresql-db bind# ( spec obj -- ) "(" 0% over [ "," 0% ] [ - sql-spec-type f lookup-type 0% + type>> f lookup-type 0% ] interleave ")" 0% " returns bigint as '" 0% @@ -150,7 +152,7 @@ M: postgresql-db bind# ( spec obj -- ) "insert into " 0% dup 0% "(" 0% - over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + over [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% swap [ ", " 0% ] [ drop bind-name% ] interleave "); " 0% @@ -169,7 +171,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) "drop function add_" 0% 0% "(" 0% remove-id - [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + [ ", " 0% ] [ type>> f lookup-type 0% ] interleave ");" 0% ] postgresql-make ; @@ -199,7 +201,7 @@ M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ")" 0% " values(" 0% @@ -216,10 +218,10 @@ M: postgresql-db ( class -- statement ) " set " 0% dup remove-id [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ dup column-name>> 0% " = " 0% bind% ] interleave " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] postgresql-make ; M: postgresql-db ( class -- statement ) @@ -227,7 +229,7 @@ M: postgresql-db ( class -- statement ) "delete from " 0% 0% " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] postgresql-make ; M: postgresql-db ( tuple class -- statement ) @@ -235,16 +237,16 @@ M: postgresql-db ( tuple class -- statement ) ! tuple columns table "select " 0% over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave + [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ " where " 0% [ " and " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ dup column-name>> 0% " = " 0% bind% ] interleave ] if ";" 0% ] postgresql-make ; @@ -276,8 +278,8 @@ M: postgresql-db create-type-table ( -- hash ) { "varchar" [ first number>string paren append ] } { "references" [ first2 >r [ unparse join-space ] keep db-columns r> - swap [ sql-spec-slot-name = ] with find nip - sql-spec-column-name paren append + swap [ slot-name>> = ] with find nip + column-name>> paren append ] } [ "no compound found" 3array throw ] } case ; From b0ddc983efc3ad7555fe4b77291a7e7bfcfc384e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:48:07 -0500 Subject: [PATCH 052/220] more refactoring --- extra/db/postgresql/lib/lib.factor | 3 +-- extra/db/postgresql/postgresql.factor | 8 +++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bb4c6872fb..56bfc29be8 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -44,7 +44,7 @@ M: postgresql-result-null summary ( obj -- str ) : do-postgresql-statement ( statement -- res ) db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ; : type>oid ( symbol -- n ) @@ -165,4 +165,3 @@ M: postgresql-malloc-destructor dispose ( obj -- ) dup [ bytes>object ] when ] } [ no-sql-type ] } case ; - ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f13bceddd3..bcf71ea95f 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -53,12 +53,15 @@ M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n ) handle>> PQnfields ; +: result-handle-n ( result-set -- handle n ) + [ handle>> ] [ n>> ] bi ; + M: postgresql-result-set row-column ( result-set column -- obj ) - >r [ handle>> ] [ n>> ] bi r> pq-get-string ; + >r result-handle-n r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) dup pick out-params>> nth type>> - >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ; + >r >r result-handle-n r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup bind-params>> [ @@ -234,7 +237,6 @@ M: postgresql-db ( class -- statement ) M: postgresql-db ( tuple class -- statement ) [ - ! tuple columns table "select " 0% over [ ", " 0% ] [ dup column-name>> 0% 2, ] interleave From 10ee5cf8ed55c2ec6fb9f5067e3fb0eebe54447d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 00:18:27 -0500 Subject: [PATCH 053/220] Fix bootstrap --- core/bootstrap/primitives.factor | 51 ------------------------ core/bootstrap/syntax.factor | 3 -- core/prettyprint/backend/backend.factor | 3 -- core/syntax/syntax.factor | 6 +-- extra/bit-vectors/bit-vectors.factor | 15 ++++++- extra/byte-vectors/byte-vectors.factor | 17 +++++++- extra/float-vectors/float-vectors.factor | 15 ++++++- 7 files changed, 46 insertions(+), 64 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f1e41ac2b6..061866fe3e 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -58,16 +58,13 @@ num-types get f builtins set "alien.accessors" "arrays" "bit-arrays" - "bit-vectors" "byte-arrays" - "byte-vectors" "classes.private" "classes.tuple" "classes.tuple.private" "compiler.units" "continuations.private" "float-arrays" - "float-vectors" "generator" "growable" "hashtables" @@ -455,54 +452,6 @@ tuple } } define-tuple-class -"byte-vector" "byte-vectors" create -tuple -{ - { - { "byte-array" "byte-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"bit-vector" "bit-vectors" create -tuple -{ - { - { "bit-array" "bit-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"float-vector" "float-vectors" create -tuple -{ - { - { "float-array" "float-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - "curry" "kernel" create tuple { diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 4d5f31dc82..4b74804749 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -14,16 +14,13 @@ IN: bootstrap.syntax ";" "pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; M: vector >pprint-sequence ; -M: bit-vector >pprint-sequence ; -M: byte-vector >pprint-sequence ; -M: float-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index f6252a3e16..566f5471f4 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays bit-vectors byte-arrays -byte-vectors definitions generic hashtables kernel math +USING: alien arrays bit-arrays byte-arrays +definitions generic hashtables kernel math namespaces parser sequences strings sbufs vectors words quotations io assocs splitting classes.tuple generic.standard -generic.math classes io.files vocabs float-arrays float-vectors +generic.math classes io.files vocabs float-arrays classes.union classes.mixin classes.predicate classes.singleton compiler.units combinators debugger ; IN: bootstrap.syntax diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index a6e8ebe90a..b011f146c5 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -5,6 +5,16 @@ sequences.private growable bit-arrays prettyprint.backend parser ; IN: bit-vectors +TUPLE: bit-vector underlying fill ; + +M: bit-vector underlying underlying>> { bit-array } declare ; + +M: bit-vector set-underlying (>>underlying) ; + +M: bit-vector length fill>> { array-capacity } declare ; + +M: bit-vector set-fill (>>fill) ; + vector ( bit-array length -- bit-vector ) @@ -15,7 +25,8 @@ PRIVATE> : ( n -- bit-vector ) 0 bit-array>vector ; inline -: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ; +: >bit-vector ( seq -- bit-vector ) + T{ bit-vector f ?{ } 0 } clone-like ; M: bit-vector like drop dup bit-vector? [ @@ -35,4 +46,6 @@ INSTANCE: bit-vector growable : ?V \ } [ >bit-vector ] parse-literal ; parsing +M: bit-vector >pprint-sequence ; + M: bit-vector pprint-delims drop \ ?V{ \ } ; diff --git a/extra/byte-vectors/byte-vectors.factor b/extra/byte-vectors/byte-vectors.factor index 4d998bdfd6..a8351dc781 100755 --- a/extra/byte-vectors/byte-vectors.factor +++ b/extra/byte-vectors/byte-vectors.factor @@ -2,9 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable byte-arrays prettyprint.backend -parser ; +parser accessors ; IN: byte-vectors +TUPLE: byte-vector underlying fill ; + +M: byte-vector underlying underlying>> { byte-array } declare ; + +M: byte-vector set-underlying (>>underlying) ; + +M: byte-vector length fill>> { array-capacity } declare ; + +M: byte-vector set-fill (>>fill) ; + vector ( byte-array length -- byte-vector ) @@ -15,7 +25,8 @@ PRIVATE> : ( n -- byte-vector ) 0 byte-array>vector ; inline -: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ; +: >byte-vector ( seq -- byte-vector ) + T{ byte-vector f B{ } 0 } clone-like ; M: byte-vector like drop dup byte-vector? [ @@ -35,4 +46,6 @@ INSTANCE: byte-vector growable : BV{ \ } [ >byte-vector ] parse-literal ; parsing +M: byte-vector >pprint-sequence ; + M: byte-vector pprint-delims drop \ BV{ \ } ; diff --git a/extra/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor index f3f6b12090..f0db37610a 100755 --- a/extra/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -5,6 +5,16 @@ sequences.private growable float-arrays prettyprint.backend parser ; IN: float-vectors +TUPLE: float-vector underlying fill ; + +M: float-vector underlying underlying>> { float-array } declare ; + +M: float-vector set-underlying (>>underlying) ; + +M: float-vector length fill>> { array-capacity } declare ; + +M: float-vector set-fill (>>fill) ; + vector ( float-array length -- float-vector ) @@ -15,7 +25,8 @@ PRIVATE> : ( n -- float-vector ) 0.0 0 float-array>vector ; inline -: >float-vector ( seq -- float-vector ) FV{ } clone-like ; +: >float-vector ( seq -- float-vector ) + T{ float-vector f F{ } 0 } clone-like ; M: float-vector like drop dup float-vector? [ @@ -35,4 +46,6 @@ INSTANCE: float-vector growable : FV{ \ } [ >float-vector ] parse-literal ; parsing +M: float-vector >pprint-sequence ; + M: float-vector pprint-delims drop \ FV{ \ } ; From 7293a4f4f8013ce6af452e6921d46f40d91680b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 20 Apr 2008 00:20:21 -0500 Subject: [PATCH 054/220] clean up the tuples tests --- extra/db/tuples/tuples-tests.factor | 36 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 038197d864..0648f9b254 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -212,9 +212,6 @@ TUPLE: serialize-me id data ; { T{ serialize-me f 1 H{ { 1 2 } } } } ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -[ test-serialize ] test-sqlite -! [ test-serialize ] test-postgresql - TUPLE: exam id name score ; : test-intervals ( -- ) @@ -288,8 +285,6 @@ TUPLE: exam id name score ; T{ exam f T{ range f 1 3 1 } } select-tuples ] unit-test ; -[ test-intervals ] test-sqlite - TUPLE: bignum-test id m n o ; : ( m n o -- obj ) bignum-test new @@ -313,15 +308,6 @@ TUPLE: bignum-test id m n o ; -9223372036854775808 9223372036854775808 -9223372036854775808 } ] [ T{ bignum-test f 1 } select-tuple ] unit-test ; -[ test-bignum ] test-sqlite - -TUPLE: does-not-persist ; - -[ - [ does-not-persist create-sql-statement ] - [ class \ not-persistent = ] must-fail-with -] test-sqlite - TUPLE: secret n message ; C: secret @@ -349,15 +335,33 @@ C: secret T{ secret } select-tuples length 3 = ] unit-test ; -[ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-repeated-insert ] test-sqlite +[ test-bignum ] test-sqlite +[ test-serialize ] test-sqlite +[ test-intervals ] test-sqlite +[ test-random-id ] test-sqlite -[ test-random-id ] test-postgresql [ native-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-repeated-insert ] test-postgresql +[ test-bignum ] test-sqlite +[ test-serialize ] test-postgresql +! [ test-intervals ] test-postgresql +! [ test-random-id ] test-postgresql + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer From 851c54ea7a71ac9b566ecc78298635703b8c5fa0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 00:49:42 -0500 Subject: [PATCH 055/220] Cleaning up deployment tool --- extra/tools/deploy/deploy.factor | 11 +++++--- extra/tools/deploy/macosx/macosx.factor | 19 +++++++------ extra/tools/deploy/unix/unix.factor | 34 +++++++++++------------ extra/tools/deploy/windows/windows.factor | 5 ++-- extra/windows/shell32/shell32.factor | 4 +-- 5 files changed, 39 insertions(+), 34 deletions(-) diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index bbeadc40cd..e57cc1f04b 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -1,10 +1,13 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.deploy.backend system vocabs.loader kernel ; +USING: tools.deploy.backend system vocabs.loader kernel +combinators ; IN: tools.deploy : deploy ( vocab -- ) deploy* ; -os macosx? [ "tools.deploy.macosx" require ] when -os winnt? [ "tools.deploy.windows" require ] when -os unix? [ "tools.deploy.unix" require ] when \ No newline at end of file +{ + { [ os macosx? ] [ "tools.deploy.macosx" ] } + { [ os winnt? ] [ "tools.deploy.windows" ] } + { [ os unix? ] [ "tools.deploy.unix" ] } +} cond require \ No newline at end of file diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index ca710e9d28..d38b40db4b 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -31,10 +31,14 @@ IN: tools.deploy.macosx write-plist ; : create-app-dir ( vocab bundle-name -- vm ) - dup "Frameworks" copy-bundle-dir - dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir - dup "Contents/Resources/" copy-fonts - 2dup create-app-plist "Contents/MacOS/" append-path "" copy-vm ; + [ + nip + [ "Frameworks" copy-bundle-dir ] + [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ] + [ "Contents/Resources/" copy-fonts ] tri + ] + [ create-app-plist ] + [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ; : deploy.app-image ( vocab bundle-name -- str ) [ % "/Contents/Resources/" % % ".image" % ] "" make ; @@ -43,9 +47,8 @@ IN: tools.deploy.macosx deploy-name get ".app" append ; : show-in-finder ( path -- ) - NSWorkspace - -> sharedWorkspace - over rot parent-directory + [ NSWorkspace -> sharedWorkspace ] + [ normalize-path [ ] [ parent-directory ] bi ] bi* -> selectFile:inFileViewerRootedAtPath: drop ; M: macosx deploy* ( vocab -- ) @@ -56,6 +59,6 @@ M: macosx deploy* ( vocab -- ) [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image - bundle-name normalize-path show-in-finder + bundle-name show-in-finder ] bind ] with-directory ; diff --git a/extra/tools/deploy/unix/unix.factor b/extra/tools/deploy/unix/unix.factor index a995d66cd8..6f5a0304a2 100644 --- a/extra/tools/deploy/unix/unix.factor +++ b/extra/tools/deploy/unix/unix.factor @@ -3,21 +3,21 @@ USING: io io.files io.backend kernel namespaces sequences system tools.deploy.backend tools.deploy.config assocs hashtables prettyprint ; -IN: tools.deploy.linux - -: create-app-dir ( vocab bundle-name -- vm ) - dup "" copy-fonts - "" copy-vm ; - -: bundle-name ( -- str ) - deploy-name get ; +IN: tools.deploy.unix -M: linux deploy* ( vocab -- ) - "." resource-path [ - dup deploy-config [ - [ bundle-name create-app-dir ] keep - [ bundle-name image-name ] keep - namespace make-deploy-image - bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print - ] bind - ] with-directory ; \ No newline at end of file +: create-app-dir ( vocab bundle-name -- vm ) + dup "" copy-fonts + "" copy-vm ; + +: bundle-name ( -- str ) + deploy-name get ; + +M: unix deploy* ( vocab -- ) + "." resource-path [ + dup deploy-config [ + [ bundle-name create-app-dir ] keep + [ bundle-name image-name ] keep + namespace make-deploy-image + bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print + ] bind + ] with-directory ; \ No newline at end of file diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 4f6527a4ce..5af3062e39 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -6,8 +6,7 @@ prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dlls ( bundle-name -- ) - { "freetype6.dll" "zlib1.dll" "factor.dll" } - [ resource-path ] map + { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" } swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) @@ -21,6 +20,6 @@ M: winnt deploy* [ deploy-name get create-exe-dir ] keep [ deploy-name get image-name ] keep [ namespace make-deploy-image ] keep - (normalize-path) open-in-explorer + open-in-explorer ] bind ] with-directory ; diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor index d64fb68cb3..f938ca15e6 100644 --- a/extra/windows/shell32/shell32.factor +++ b/extra/windows/shell32/shell32.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.syntax combinators kernel windows windows.user32 windows.ole32 -windows.com windows.com.syntax ; +windows.com windows.com.syntax io.files ; IN: windows.shell32 : CSIDL_DESKTOP HEX: 00 ; inline @@ -83,7 +83,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi : ShellExecute ShellExecuteW ; inline : open-in-explorer ( dir -- ) - f "open" rot f f SW_SHOWNORMAL ShellExecute drop ; + f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ; : shell32-error ( n -- ) ole32-error ; inline From c564481cc52a66de5af96ccd3c52ee3c460458cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 00:51:10 -0500 Subject: [PATCH 056/220] Add columns vocab --- extra/columns/authors.txt | 2 ++ extra/columns/columns-docs.factor | 26 ++++++++++++++++++++++++++ extra/columns/columns-tests.factor | 9 +++++++++ extra/columns/columns.factor | 15 +++++++++++++++ extra/columns/summary.txt | 1 + extra/columns/tags.txt | 1 + 6 files changed, 54 insertions(+) create mode 100644 extra/columns/authors.txt create mode 100644 extra/columns/columns-docs.factor create mode 100644 extra/columns/columns-tests.factor create mode 100644 extra/columns/columns.factor create mode 100644 extra/columns/summary.txt create mode 100644 extra/columns/tags.txt diff --git a/extra/columns/authors.txt b/extra/columns/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/extra/columns/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor new file mode 100644 index 0000000000..6b2adce9d9 --- /dev/null +++ b/extra/columns/columns-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax sequences ; +IN: columns + +ARTICLE: "columns" "Column sequences" +"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" +{ $subsection column } +{ $subsection } ; + +HELP: column +{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; + +HELP: ( seq n -- column ) +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } +{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } +{ $examples + { $example + "USING: arrays prettyprint sequences ;" + "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." + "{ 1 4 7 }" + } +} +{ $notes + "In the same sense that " { $link } " is a virtual variant of " { $link reverse } ", " { $link } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "." +} ; + +ABOUT: "columns" diff --git a/extra/columns/columns-tests.factor b/extra/columns/columns-tests.factor new file mode 100644 index 0000000000..657b9e0a25 --- /dev/null +++ b/extra/columns/columns-tests.factor @@ -0,0 +1,9 @@ +IN: columns.tests +USING: columns sequences kernel namespaces arrays tools.test math ; + +! Columns +{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set + +[ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test +[ ] [ "seq" get 1 [ sq ] change-each ] unit-test +[ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test diff --git a/extra/columns/columns.factor b/extra/columns/columns.factor new file mode 100644 index 0000000000..7e4a7fd408 --- /dev/null +++ b/extra/columns/columns.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel accessors ; +IN: columns + +! A column of a matrix +TUPLE: column seq col ; + +C: column + +M: column virtual-seq seq>> ; +M: column virtual@ dup col>> -rot seq>> nth bounds-check ; +M: column length seq>> length ; + +INSTANCE: column virtual-sequence diff --git a/extra/columns/summary.txt b/extra/columns/summary.txt new file mode 100644 index 0000000000..c4ade7fb51 --- /dev/null +++ b/extra/columns/summary.txt @@ -0,0 +1 @@ +Virtual sequence view of a matrix column diff --git a/extra/columns/tags.txt b/extra/columns/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/columns/tags.txt @@ -0,0 +1 @@ +collections From 89a728f645cf92f9482716c811ef411edca78f3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 20 Apr 2008 00:52:05 -0500 Subject: [PATCH 057/220] about to consolidate sql types/create types/modifiers --- extra/db/postgresql/postgresql.factor | 30 +++++++++++---------------- extra/db/sqlite/sqlite.factor | 16 +++++++------- extra/db/types/types.factor | 7 +++---- 3 files changed, 22 insertions(+), 31 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index bcf71ea95f..5f98720de0 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -93,7 +93,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) dup - >r db get handle>> "" r> + >r db get handle>> f r> [ sql>> ] [ in-params>> ] bi length f PQprepare postgresql-error >>handle drop ; @@ -274,21 +274,6 @@ M: postgresql-db create-type-table ( -- hash ) { +random-id+ "bigint primary key" } } ; -: postgresql-compound ( str n -- newstr ) - over { - { "default" [ first number>string join-space ] } - { "varchar" [ first number>string paren append ] } - { "references" [ - first2 >r [ unparse join-space ] keep db-columns r> - swap [ slot-name>> = ] with find nip - column-name>> paren append - ] } - [ "no compound found" 3array throw ] - } case ; - -M: postgresql-db compound-modifier ( str seq -- newstr ) - postgresql-compound ; - M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } @@ -305,5 +290,14 @@ M: postgresql-db modifier-table ( -- hashtable ) { random-generator "" } } ; -M: postgresql-db compound-type ( str n -- newstr ) - postgresql-compound ; +M: postgresql-db compound ( str obj -- str' ) + over { + { "default" [ first number>string join-space ] } + { "varchar" [ first number>string paren append ] } + { "references" [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ slot-name>> = ] with find nip + column-name>> paren append + ] } + [ "no compound found" 3array throw ] + } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index f361e18c48..fb3fbe92be 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -110,7 +110,6 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; - : maybe-make-retryable ( statement -- statement ) dup in-params>> [ generator-bind? ] contains? [ make-retryable @@ -263,14 +262,6 @@ M: sqlite-db modifier-table ( -- hashtable ) { random-generator "" } } ; -M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; - -M: sqlite-db compound-type ( str seq -- str' ) - over { - { "default" [ first number>string join-space ] } - [ 2drop ] - } case ; - M: sqlite-db type-table ( -- assoc ) H{ { +native-id+ "integer primary key" } @@ -291,3 +282,10 @@ M: sqlite-db type-table ( -- assoc ) } ; M: sqlite-db create-type-table ( symbol -- str ) type-table ; + +M: sqlite-db compound ( str seq -- str' ) + over { + { "default" [ first number>string join-space ] } + [ 2drop ] + } case ; + diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 41db970b12..80e11e7afb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -8,10 +8,9 @@ classes.singleton accessors quotations random ; IN: db.types HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str seq -- hash ) +HOOK: compound db ( str obj -- hash ) HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) -HOOK: compound-type db ( str n -- hash ) HOOK: random-id-quot db ( -- quot ) TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; @@ -100,7 +99,7 @@ ERROR: unknown-modifier ; : lookup-modifier ( obj -- str ) { - { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] } + { [ dup array? ] [ unclip lookup-modifier swap compound ] } [ modifier-table at* [ unknown-modifier ] unless ] } cond ; @@ -115,7 +114,7 @@ ERROR: no-sql-type ; : lookup-create-type ( obj -- str ) dup array? [ - unclip lookup-create-type swap compound-type + unclip lookup-create-type swap compound ] [ dup create-type-table at* [ nip ] [ drop lookup-type* ] if From 6c70907354d122dc48847db3bf6dbec4d69ca8f6 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 19 Apr 2008 23:41:18 -0700 Subject: [PATCH 058/220] Add sequences.lib.reduce-index --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 15983329d6..8e3d394754 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -35,6 +35,10 @@ MACRO: firstn ( n -- ) #! quot: ( elt index -- obj ) prepare-index 2map ; inline +: reduce-index ( seq identity quot -- ) + #! quot: ( prev elt index -- next ) + swapd each-index ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) From fbe7fb58dd0164bf134273c7b6edf739c3a1f788 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 19 Apr 2008 23:41:26 -0700 Subject: [PATCH 059/220] Add project-euler.148 --- extra/project-euler/148/148.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 extra/project-euler/148/148.factor diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor new file mode 100644 index 0000000000..daad89a40c --- /dev/null +++ b/extra/project-euler/148/148.factor @@ -0,0 +1,24 @@ +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions sequences sequences.lib ; + +IN: project-euler.148 + +base7 ( x -- y ) + [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ; + +: (use-digit) ( prev x index -- next ) + [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; + +PRIVATE> + +: (euler148) ( x -- y ) + >base7 0 [ (use-digit) ] reduce-index ; + +: euler148 ( -- y ) + 10 9 ^ (euler148) ; From d1f37ab5ecbee1633028ac8118607e0527e5ab47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 02:30:52 -0500 Subject: [PATCH 060/220] Fix bloopers --- .../io/encodings/utf16/.utf16.factor.swo | Bin {extra => core}/io/encodings/utf16/authors.txt | 0 {extra => core}/io/encodings/utf16/summary.txt | 0 {extra => core}/io/encodings/utf16/tags.txt | 0 .../io/encodings/utf16/utf16-docs.factor | 0 .../io/encodings/utf16/utf16-tests.factor | 0 {extra => core}/io/encodings/utf16/utf16.factor | 8 ++++---- extra/benchmark/spectral-norm/spectral-norm.factor | 4 ++-- extra/bit-vectors/bit-vectors.factor | 4 ++-- extra/float-vectors/float-vectors.factor | 2 +- 10 files changed, 9 insertions(+), 9 deletions(-) rename {extra => core}/io/encodings/utf16/.utf16.factor.swo (100%) rename {extra => core}/io/encodings/utf16/authors.txt (100%) rename {extra => core}/io/encodings/utf16/summary.txt (100%) rename {extra => core}/io/encodings/utf16/tags.txt (100%) rename {extra => core}/io/encodings/utf16/utf16-docs.factor (100%) rename {extra => core}/io/encodings/utf16/utf16-tests.factor (100%) rename {extra => core}/io/encodings/utf16/utf16.factor (95%) diff --git a/extra/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from extra/io/encodings/utf16/.utf16.factor.swo rename to core/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from extra/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/extra/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from extra/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt similarity index 100% rename from extra/io/encodings/utf16/tags.txt rename to core/io/encodings/utf16/tags.txt diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from extra/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from extra/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/extra/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 95% rename from extra/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index fbc296e57c..953671d7f4 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -126,11 +126,11 @@ M: utf16 ( stream utf16 -- encoder ) ! Native-order UTF-16 -: native-utf16 ( -- descriptor ) - little-endian? utf16le utf16be ? ; +: utf16n ( -- descriptor ) + little-endian? utf16le utf16be ? ; foldable -M: utf16n drop native-utf16 ; +M: utf16n drop utf16n ; -M: utf16n drop native-utf16 ; +M: utf16n drop utf16n ; PRIVATE> diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 2c7dc1e80d..7eddeefc1b 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -19,7 +19,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-A-times-u) r> + ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline + ] F{ } map-as 2nip ; inline : (eval-At-times-u) ( u i j -- x ) tuck swap eval-A >r swap nth-unsafe r> * ; inline @@ -29,7 +29,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-At-times-u) r> + ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline + ] F{ } map-as 2nip ; inline : eval-AtA-times-u ( n u -- seq ) dupd eval-A-times-u eval-At-times-u ; inline diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index b011f146c5..c14b0a5476 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.backend -parser ; +parser accessors ; IN: bit-vectors TUPLE: bit-vector underlying fill ; @@ -44,7 +44,7 @@ M: bit-array new-resizable drop ; INSTANCE: bit-vector growable -: ?V \ } [ >bit-vector ] parse-literal ; parsing +: ?V{ \ } [ >bit-vector ] parse-literal ; parsing M: bit-vector >pprint-sequence ; diff --git a/extra/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor index f0db37610a..d51f0d4e44 100755 --- a/extra/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable float-arrays prettyprint.backend -parser ; +parser accessors ; IN: float-vectors TUPLE: float-vector underlying fill ; From e2a185f1f45696d3c3102196f02f6e7c1e597357 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 04:19:06 -0500 Subject: [PATCH 061/220] Web framework work in progress --- .../server/boilerplate/boilerplate.factor | 23 ++- .../server/components/components-tests.factor | 2 + .../http/server/components/components.factor | 95 +++++++--- .../server/components/farkup/farkup.factor | 6 +- extra/http/server/forms/forms.factor | 5 +- .../http/server/templating/chloe/chloe.factor | 29 ++- .../server/validators/validators-tests.factor | 6 + .../http/server/validators/validators.factor | 7 +- extra/webapps/planet/authors.txt | 1 + extra/webapps/planet/blog-summary.xml | 7 + extra/webapps/planet/edit-blog.xml | 40 ++++ extra/webapps/planet/entry-summary.xml | 10 + extra/webapps/planet/entry.xml | 9 + extra/webapps/planet/mini-planet.xml | 7 + extra/webapps/planet/page.xml | 64 +++++++ extra/webapps/planet/planet.css | 30 +++ extra/webapps/planet/planet.factor | 174 ++++++++++++++++++ extra/webapps/planet/planet.xml | 37 ++++ extra/webapps/planet/view-blog.xml | 41 +++++ 19 files changed, 557 insertions(+), 36 deletions(-) create mode 100755 extra/webapps/planet/authors.txt create mode 100644 extra/webapps/planet/blog-summary.xml create mode 100644 extra/webapps/planet/edit-blog.xml create mode 100644 extra/webapps/planet/entry-summary.xml create mode 100644 extra/webapps/planet/entry.xml create mode 100644 extra/webapps/planet/mini-planet.xml create mode 100644 extra/webapps/planet/page.xml create mode 100644 extra/webapps/planet/planet.css create mode 100755 extra/webapps/planet/planet.factor create mode 100644 extra/webapps/planet/planet.xml create mode 100644 extra/webapps/planet/view-blog.xml diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 4e847cff70..6c62452ec2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string +io io.streams.string arrays +html.elements http http.server http.server.templating ; @@ -28,6 +29,18 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + SYMBOL: nested-template? SYMBOL: next-template @@ -40,6 +53,7 @@ M: f call-template drop call-next-template ; : with-boilerplate ( body template -- ) [ title get [ title set ] unless + atom-feed get [ atom-feed set ] unless style get [ SBUF" " clone style set ] unless [ @@ -54,5 +68,8 @@ M: f call-template drop call-next-template ; ] with-scope ; inline M: boilerplate call-responder - [ responder>> call-responder clone ] [ template>> ] bi - [ [ with-boilerplate ] 2curry ] curry change-body ; + tuck responder>> call-responder + dup "content-type" header "text/html" = [ + clone swap template>> + [ [ with-boilerplate ] 2curry ] curry change-body + ] [ nip ] if ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 6d3a048ac4..ff87bb71fb 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test [ ] [ "password" "p" set ] unit-test + +[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 50353c6b87..bdcdd95c71 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements http.server.validators accessors namespaces -kernel io math.parser assocs classes words classes.tuple arrays -sequences splitting mirrors hashtables fry combinators -continuations math ; +USING: accessors namespaces kernel io math.parser assocs classes +words classes.tuple arrays sequences splitting mirrors +hashtables fry combinators continuations math +calendar.format html.elements +http.server.validators ; IN: http.server.components ! Renderer protocol @@ -59,9 +60,14 @@ SYMBOL: values : values-tuple values get mirror-object ; +: render-view-or-summary ( component -- value renderer ) + [ id>> value ] [ component-string ] [ renderer>> ] tri ; + : render-view ( component -- ) - [ id>> value ] [ component-string ] [ renderer>> ] tri - render-view* ; + render-view-or-summary render-view* ; + +: render-summary ( component -- ) + render-view-or-summary render-summary* ; ( id -- component ) + url new-string + 5 >>min-length + 60 >>max-length ; + +M: url validate* + call-next-method dup empty? [ v-url ] unless ; + ! Don't send passwords back to the user TUPLE: password-renderer < field ; @@ -206,20 +223,20 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer rows cols ; +TUPLE: text-renderer rows cols ; -: new-textarea-renderer ( class -- renderer ) +: new-text-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; -: ( -- renderer ) - textarea-renderer new-textarea-renderer ; +: ( -- renderer ) + text-renderer new-text-renderer ; -M: textarea-renderer render-view* +M: text-renderer render-view* drop write ; -M: textarea-renderer render-edit* +M: text-renderer render-edit*