diff --git a/.gitignore b/.gitignore index a839a6ff19..3bc5a6ffda 100644 --- a/.gitignore +++ b/.gitignore @@ -8,7 +8,9 @@ Factor/factor *.a *.dll *.lib +*.exp *.res +*.RES *.image *.dylib factor diff --git a/Nmakefile b/Nmakefile index 7457ea43be..7349deae23 100755 --- a/Nmakefile +++ b/Nmakefile @@ -61,7 +61,7 @@ DLL_OBJS = vm\os-windows-nt.obj \ .rs.res: rc $< -all: factor.com factor.exe +all: factor.com factor.exe libfactor-ffi-test.dll libfactor-ffi-test.dll: vm/ffi_test.obj link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index d134d57189..faee8955e9 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,6 +1,7 @@ USING: alien alien.syntax alien.c-types alien.parser eval kernel tools.test sequences system libc alien.strings -io.encodings.utf8 math.constants classes.struct classes ; +io.encodings.utf8 math.constants classes.struct classes +accessors compiler.units ; IN: alien.c-types.tests CONSTANT: xyz 123 @@ -100,3 +101,12 @@ DEFER: struct-redefined \ struct-redefined class? ] unit-test +[ + "IN: alien.c-types.tests + USE: alien.syntax + USE: alien.c-types + TYPEDEF: int type-redefinition-test + TYPEDEF: int type-redefinition-test" eval( -- ) +] +[ error>> error>> redefine-error? ] +must-fail-with diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 24221160ce..e2f15f5de8 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -78,6 +78,9 @@ M: string resolve-pointer-type [ resolve-pointer-type ] [ drop void* ] if ] if ; +M: array resolve-pointer-type + first resolve-pointer-type ; + : resolve-typedef ( name -- c-type ) dup void? [ no-c-type ] when dup c-type-name? [ c-type ] when ; @@ -551,9 +554,6 @@ M: ulonglong-2-rep rep-component-type drop ulonglong ; M: float-4-rep rep-component-type drop float ; M: double-2-rep rep-component-type drop double ; -: rep-length ( rep -- n ) - 16 swap rep-component-type heap-size /i ; foldable - : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 238207f192..80a5ec8bae 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -3,12 +3,13 @@ USING: accessors alien alien.c-types alien.complex alien.data alien.fortran alien.fortran.private alien.strings classes.struct arrays assocs byte-arrays combinators fry generalizations io.encodings.ascii kernel macros -macros.expander namespaces sequences shuffle tools.test ; +macros.expander namespaces sequences shuffle tools.test vocabs.parser ; +QUALIFIED-WITH: alien.c-types c IN: alien.fortran.tests << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> LIBRARY: (alien.fortran-tests) -STRUCT: FORTRAN_TEST_RECORD +STRUCT: fortran_test_record { FOO int } { BAR double[2] } { BAS char[4] } ; @@ -23,148 +24,163 @@ intel-unix-abi fortran-abi [ ! fortran-type>c-type - [ "short" ] + [ c:short ] [ "integer*2" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "integer*4" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "INTEGER" fortran-type>c-type ] unit-test - [ "longlong" ] + [ c:longlong ] [ "iNteger*8" fortran-type>c-type ] unit-test - [ "int[0]" ] + [ { c:int 0 } ] [ "integer(*)" fortran-type>c-type ] unit-test - [ "int[0]" ] + [ { c:int 0 } ] [ "integer(3,*)" fortran-type>c-type ] unit-test - [ "int[3]" ] + [ { c:int 3 } ] [ "integer(3)" fortran-type>c-type ] unit-test - [ "int[6]" ] + [ { c:int 6 } ] [ "integer(3,2)" fortran-type>c-type ] unit-test - [ "int[24]" ] + [ { c:int 24 } ] [ "integer(4,3,2)" fortran-type>c-type ] unit-test - [ "char" ] + [ c:char ] [ "character" fortran-type>c-type ] unit-test - [ "char" ] + [ c:char ] [ "character*1" fortran-type>c-type ] unit-test - [ "char[17]" ] + [ { c:char 17 } ] [ "character*17" fortran-type>c-type ] unit-test - [ "char[17]" ] + [ { c:char 17 } ] [ "character(17)" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "logical" fortran-type>c-type ] unit-test - [ "float" ] + [ c:float ] [ "real" fortran-type>c-type ] unit-test - [ "double" ] + [ c:double ] [ "double-precision" fortran-type>c-type ] unit-test - [ "float" ] + [ c:float ] [ "real*4" fortran-type>c-type ] unit-test - [ "double" ] + [ c:double ] [ "real*8" fortran-type>c-type ] unit-test - [ "complex-float" ] + [ complex-float ] [ "complex" fortran-type>c-type ] unit-test - [ "complex-double" ] + [ complex-double ] [ "double-complex" fortran-type>c-type ] unit-test - [ "complex-float" ] + [ complex-float ] [ "complex*8" fortran-type>c-type ] unit-test - [ "complex-double" ] + [ complex-double ] [ "complex*16" fortran-type>c-type ] unit-test - [ "fortran_test_record" ] - [ "fortran_test_record" fortran-type>c-type ] unit-test + [ fortran_test_record ] + [ + [ + "alien.fortran.tests" use-vocab + "fortran_test_record" fortran-type>c-type + ] with-manifest + ] unit-test ! fortran-arg-type>c-type - [ "int*" { } ] + [ c:void* { } ] [ "integer" fortran-arg-type>c-type ] unit-test - [ "int*" { } ] + [ c:void* { } ] [ "integer(3)" fortran-arg-type>c-type ] unit-test - [ "int*" { } ] + [ c:void* { } ] [ "integer(*)" fortran-arg-type>c-type ] unit-test - [ "fortran_test_record*" { } ] - [ "fortran_test_record" fortran-arg-type>c-type ] unit-test + [ c:void* { } ] + [ + [ + "alien.fortran.tests" use-vocab + "fortran_test_record" fortran-arg-type>c-type + ] with-manifest + ] unit-test - [ "char*" { } ] + [ c:char* { } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "char*" { } ] + [ c:char* { } ] [ "character(1)" fortran-arg-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { long } ] [ "character(17)" fortran-arg-type>c-type ] unit-test ! fortran-ret-type>c-type - [ "char" { } ] + [ c:char { } ] [ "character(1)" fortran-ret-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* long } ] [ "character(17)" fortran-ret-type>c-type ] unit-test - [ "int" { } ] + [ c:int { } ] [ "integer" fortran-ret-type>c-type ] unit-test - [ "int" { } ] + [ c:int { } ] [ "logical" fortran-ret-type>c-type ] unit-test - [ "float" { } ] + [ c:float { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { c:void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test - [ "double" { } ] + [ c:double { } ] [ "double-precision" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-float*" } ] + [ c:void { c:void* } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-double*" } ] + [ c:void { c:void* } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "void" { "int*" } ] + [ c:void { c:void* } ] [ "integer(*)" fortran-ret-type>c-type ] unit-test - [ "void" { "fortran_test_record*" } ] - [ "fortran_test_record" fortran-ret-type>c-type ] unit-test + [ c:void { c:void* } ] + [ + [ + "alien.fortran.tests" use-vocab + "fortran_test_record" fortran-ret-type>c-type + ] with-manifest + ] unit-test ! fortran-sig>c-sig - [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ c:float { c:void* c:char* c:void* c:void* c:long } ] [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] unit-test - [ "char" { "char*" "char*" "int*" "long" } ] + [ c:char { c:char* c:char* c:void* c:long } ] [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ] [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ c:void { c:void* c:char* c:char* c:void* c:long } ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test @@ -184,8 +200,8 @@ intel-unix-abi fortran-abi [ } 5 ncleave ! [fortran-invoke] [ - "void" "funpack" "funtimes_" - { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } + c:void "funpack" "funtimes_" + { c:char* c:void* c:void* c:void* c:void* c:long } alien-invoke ] 6 nkeep ! [fortran-results>] @@ -210,7 +226,7 @@ intel-unix-abi fortran-abi [ [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] - [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ] + [ c:float "funpack" "fun_times_" { void* } alien-invoke ] 1 nkeep ! [fortran-results>] shuffle( reta aa -- reta aa ) @@ -222,13 +238,13 @@ intel-unix-abi fortran-abi [ [ [ ! [] - [ "complex-float" ] 1 ndip + [ complex-float ] 1 ndip ! [fortran-args>c-args] { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "complex-float*" "float*" } + c:void "funpack" "fun_times_" + { void* void* } alien-invoke ] 2 nkeep ! [fortran-results>] @@ -244,8 +260,8 @@ intel-unix-abi fortran-abi [ [ 20 20 ] 0 ndip ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "char*" "long" } + c:void "funpack" "fun_times_" + { c:char* long } alien-invoke ] 2 nkeep ! [fortran-results>] @@ -270,8 +286,8 @@ intel-unix-abi fortran-abi [ } 3 ncleave ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "char*" "long" "char*" "float*" "char*" "long" "long" } + c:void "funpack" "fun_times_" + { c:char* long c:char* c:void* c:char* c:long c:long } alien-invoke ] 7 nkeep ! [fortran-results>] @@ -302,19 +318,19 @@ intel-windows-abi fortran-abi [ f2c-abi fortran-abi [ - [ "char[1]" ] + [ { c:char 1 } ] [ "character(1)" fortran-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { c:long } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* c:long } ] [ "character" fortran-ret-type>c-type ] unit-test - [ "double" { } ] + [ c:double { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test @@ -325,34 +341,34 @@ f2c-abi fortran-abi [ gfortran-abi fortran-abi [ - [ "float" { } ] + [ c:float { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test - [ "complex-float" { } ] + [ complex-float { } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "complex-double" { } ] + [ complex-double { } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "char[1]" ] + [ { char 1 } ] [ "character(1)" fortran-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { c:long } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* c:long } ] [ "character" fortran-ret-type>c-type ] unit-test - [ "complex-float" { } ] + [ complex-float { } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "complex-double" { } ] + [ complex-double { } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-double*" } ] + [ c:void { c:void* } ] [ "double-complex(3)" fortran-ret-type>c-type ] unit-test ] with-variable diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index d7659d8400..65e927f85a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,11 +1,12 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.complex alien.data grouping -alien.strings alien.syntax arrays ascii assocs +USING: accessors alien alien.c-types alien.complex alien.data alien.parser +grouping alien.strings alien.syntax arrays ascii assocs byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges math.order sorting strings system alien.libraries ; +QUALIFIED-WITH: alien.c-types c IN: alien.fortran SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ; @@ -101,8 +102,7 @@ CONSTANT: fortran>c-types H{ } : append-dimensions ( base-c-type type -- c-type ) - dims>> - [ product number>string "[" "]" surround append ] when* ; + dims>> [ product 2array ] when* ; MACRO: size-case-type ( cases -- ) [ invalid-fortran-type ] suffix @@ -118,35 +118,35 @@ MACRO: size-case-type ( cases -- ) GENERIC: (fortran-type>c-type) ( type -- c-type ) -M: f (fortran-type>c-type) drop "void" ; +M: f (fortran-type>c-type) drop c:void ; M: integer-type (fortran-type>c-type) { - { f [ "int" ] } - { 1 [ "char" ] } - { 2 [ "short" ] } - { 4 [ "int" ] } - { 8 [ "longlong" ] } + { f [ c:int ] } + { 1 [ c:char ] } + { 2 [ c:short ] } + { 4 [ c:int ] } + { 8 [ c:longlong ] } } size-case-type ; M: real-type (fortran-type>c-type) { - { f [ "float" ] } - { 4 [ "float" ] } - { 8 [ "double" ] } + { f [ c:float ] } + { 4 [ c:float ] } + { 8 [ c:double ] } } size-case-type ; M: real-complex-type (fortran-type>c-type) { - { f [ "complex-float" ] } - { 8 [ "complex-float" ] } - { 16 [ "complex-double" ] } + { f [ complex-float ] } + { 8 [ complex-float ] } + { 16 [ complex-double ] } } size-case-type ; M: double-precision-type (fortran-type>c-type) - "double" simple-type ; + c:double simple-type ; M: double-complex-type (fortran-type>c-type) - "complex-double" simple-type ; + complex-double simple-type ; M: misc-type (fortran-type>c-type) - dup name>> simple-type ; + dup name>> parse-c-type simple-type ; : single-char? ( character-type -- ? ) { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ; @@ -158,7 +158,7 @@ M: misc-type (fortran-type>c-type) dup single-char? [ f >>dims ] when ; M: character-type (fortran-type>c-type) - fix-character-type "char" simple-type ; + fix-character-type c:char simple-type ; : dimension>number ( string -- number ) dup "*" = [ drop 0 ] [ string>number ] if ; @@ -181,13 +181,10 @@ M: character-type (fortran-type>c-type) : parse-fortran-type ( fortran-type-string/f -- type/f ) dup [ (parse-fortran-type) ] when ; -: c-type>pointer ( c-type -- c-type* ) - "[" split1 drop "*" append ; - GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; -M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ; +M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ; GENERIC: returns-by-value? ( type -- ? ) @@ -200,10 +197,10 @@ M: complex-type returns-by-value? GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) -M: f (fortran-ret-type>c-type) drop "void" ; +M: f (fortran-ret-type>c-type) drop c:void ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) - drop real-functions-return-double? [ "double" ] [ "float" ] if ; + drop real-functions-return-double? [ c:double ] [ c:float ] if ; GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) @@ -354,7 +351,7 @@ M: character-type () : (shuffle-map) ( return parameters -- ret par ) [ - fortran-ret-type>c-type length swap "void" = [ 1 + ] unless + fortran-ret-type>c-type length swap void? [ 1 + ] unless letters swap head [ "ret" swap suffix ] map ] [ [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip @@ -395,13 +392,13 @@ PRIVATE> : fortran-arg-type>c-type ( fortran-type -- c-type added-args ) parse-fortran-type - [ (fortran-type>c-type) c-type>pointer ] + [ (fortran-type>c-type) resolve-pointer-type ] [ added-c-args ] bi ; : fortran-ret-type>c-type ( fortran-type -- c-type added-args ) parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ - "void" swap - [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix + c:void swap + [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) @@ -433,7 +430,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic - return library function parameters return [ "void" ] unless* parse-arglist + return library function parameters return [ c:void ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; SYNTAX: SUBROUTINE: diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 609ed2826d..295bcff089 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman. +! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays alien alien.c-types alien.arrays alien.strings kernel math namespaces parser @@ -22,7 +22,7 @@ SYNTAX: CALLBACK: (CALLBACK:) define-inline ; SYNTAX: TYPEDEF: - scan-c-type CREATE-C-TYPE typedef ; + scan-c-type CREATE-C-TYPE dup save-location typedef ; SYNTAX: C-ENUM: ";" parse-tokens diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index aa015c5502..da71d34dce 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -8,7 +8,21 @@ $nl "If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." $nl "If the sequence is empty, outputs " { $link f } " " { $link f } "." } -{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ; +{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } +{ $examples + "Searching for an integer in a sorted array:" + { $example + "USING: binary-search math.order prettyprint ;" + "{ -13 -4 1 9 16 17 28 } [ 5 >=< ] search . ." + "1\n2" + } + "Frequently, the quotation passed to " { $link search } " is constructed by " { $link curry } " or " { $link with } " in order to make the search key a parameter:" + { $example + "USING: binary-search kernel math.order prettyprint ;" + "5 { -13 -4 1 9 16 17 28 } [ <=> ] with search . ." + "1\n2" + } +} ; { find find-from find-last find-last find-last-from search } related-words diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 2d0613a7f5..edb0bdf2ae 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors cpu.architecture vocabs.loader system sequences namespaces parser kernel kernel.private classes @@ -33,6 +33,7 @@ enable-optimizer gc : compile-unoptimized ( words -- ) + [ [ subwords ] map ] keep suffix concat [ optimized? not ] filter compile ; "debug-compiler" get [ @@ -102,7 +103,7 @@ gc "." write flush { - lines prefix suffix unclip new-assoc update + lines prefix suffix unclip new-assoc assoc-union! word-prop set-word-prop 1array 2array 3array ?nth } compile-unoptimized diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index 5bfc5f7ccc..e2de621984 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: http.client checksums checksums.md5 splitting assocs kernel io.files bootstrap.image sequences io urls ; @@ -19,9 +19,11 @@ CONSTANT: url URL" http://factorcode.org/images/latest/" ] [ drop t ] if ; : download-image ( arch -- ) - boot-image-name dup need-new-image? [ - "Downloading " write dup write "..." print - url over >url derive-url download + url swap boot-image-name >url derive-url download ; + +: maybe-download-image ( arch -- ) + dup boot-image-name need-new-image? [ + dup download-image need-new-image? [ "Boot image corrupt, or checksums.txt on server out of date" throw ] when @@ -30,6 +32,6 @@ CONSTANT: url URL" http://factorcode.org/images/latest/" drop ] if ; -: download-my-image ( -- ) my-arch download-image ; +: download-my-image ( -- ) my-arch maybe-download-image ; MAIN: download-my-image diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index c99b047686..3552f0bd92 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -545,7 +545,7 @@ M: quotation ' \ c-to-factor c-to-factor-word set \ lazy-jit-compile lazy-jit-compile-word set \ unwind-native-frames unwind-native-frames-word set - [ undefined ] undefined-quot set ; + undefined-def undefined-quot set ; : emit-special-objects ( -- ) special-objects get keys [ emit-special-object ] each ; diff --git a/basis/collada/viewer/viewer.factor b/basis/collada/viewer/viewer.factor deleted file mode 100644 index 93d8e35b27..0000000000 --- a/basis/collada/viewer/viewer.factor +++ /dev/null @@ -1,195 +0,0 @@ -! Copyright (C) 2010 Erik Charlebois -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types arrays classes.struct combinators -combinators.short-circuit game.loop game.worlds gpu gpu.buffers -gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state -gpu.textures gpu.util grouping http.client images images.loader -io io.encodings.ascii io.files io.files.temp kernel locals math -math.matrices math.vectors.simd math.parser math.vectors -method-chains namespaces sequences splitting threads ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats specialized-arrays -specialized-vectors literals collada fry xml xml.traversal sequences.deep - -opengl.gl -prettyprint ; -FROM: alien.c-types => float ; -SPECIALIZED-ARRAY: float -SPECIALIZED-VECTOR: uint -IN: collada.viewer - -GLSL-SHADER: collada-vertex-shader vertex-shader -uniform mat4 mv_matrix, p_matrix; -uniform vec3 light_position; - -attribute vec3 POSITION; -attribute vec3 NORMAL; - -void main() -{ - vec4 position = mv_matrix * vec4(POSITION, 1.0); - gl_Position = p_matrix * position; -} -; - -GLSL-SHADER: collada-fragment-shader fragment-shader -void main() -{ - gl_FragColor = vec4(1, 1, 0, 1); -} -; - -GLSL-PROGRAM: collada-program - collada-vertex-shader collada-fragment-shader ; - -GLSL-SHADER: debug-vertex-shader vertex-shader -uniform mat4 mv_matrix, p_matrix; -uniform vec3 light_position; - -attribute vec3 POSITION; -attribute vec3 COLOR; -varying vec4 color; - -void main() -{ - gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0); - color = vec4(COLOR, 1); -} -; - -GLSL-SHADER: debug-fragment-shader fragment-shader -varying vec4 color; -void main() -{ - gl_FragColor = color; -} -; - -GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ; - -UNIFORM-TUPLE: collada-uniforms < mvp-uniforms - { "light-position" vec3-uniform f } ; - -TUPLE: collada-state - models - vertex-arrays - index-vectors ; - -TUPLE: collada-world < wasd-world - { collada collada-state } ; - -VERTEX-FORMAT: collada-vertex - { "POSITION" float-components 3 f } - { "NORMAL" float-components 3 f } ; - -VERTEX-FORMAT: debug-vertex - { "POSITION" float-components 3 f } - { "COLOR" float-components 3 f } ; - -: ( models -- buffers ) -! drop -! float-array{ -0.5 0 0 1 0 0 0 1 0 0 1 0 0.5 0 0 0 0 1 } -! uint-array{ 0 1 2 } -! f model boa 1array - [ - [ attribute-buffer>> underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ] - [ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ] - [ index-buffer>> length ] tri 3array - ] map ; - -: fill-collada-state ( collada-state -- ) - dup models>> - [ - [ - first collada-program collada-vertex buffer>vertex-array - ] map >>vertex-arrays drop - ] - [ - [ - [ second ] [ third ] bi - '[ _ 0 _ uint-indexes ] call - ] map >>index-vectors drop - ] 2bi ; - -: ( -- collada-state ) - collada-state new - #! "C:/Users/erikc/Downloads/mech.dae" - "/Users/erikc/Documents/mech.dae" - file>xml "mesh" deep-tags-named [ mesh>models ] map flatten >>models ; - -M: collada-world begin-game-world - init-gpu - { 0.0 0.0 2.0 } 0 0 set-wasd-view - [ fill-collada-state drop ] [ >>collada drop ] 2bi ; - -: ( world -- uniforms ) - [ wasd-mv-matrix ] [ wasd-p-matrix ] bi - { -10000.0 10000.0 10000.0 } ! light position - collada-uniforms boa ; - -: draw-line ( world from to color -- ) - [ 3 head ] tri@ dup -rot append -rot append swap append >float-array - underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer - debug-program debug-vertex buffer>vertex-array - - { 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer - 2 '[ _ 0 _ uint-indexes ] call - - rot - - { - { "primitive-mode" [ 3drop lines-mode ] } - { "uniforms" [ nip nip ] } - { "vertex-array" [ drop drop ] } - { "indexes" [ drop nip ] } - } 3 render ; - -: draw-lines ( world lines -- ) - 3 [ first3 draw-line ] with each ; inline - -: draw-axes ( world -- ) - { { 0 0 0 } { 1 0 0 } { 1 0 0 } - { 0 0 0 } { 0 1 0 } { 0 1 0 } - { 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ; - -: draw-collada ( world -- ) - GL_COLOR_BUFFER_BIT glClear - - [ - triangle-lines dup t set-gpu-state - [ collada>> vertex-arrays>> ] - [ collada>> index-vectors>> ] - [ ] - tri - [ - { - { "primitive-mode" [ 3drop triangles-mode ] } - { "uniforms" [ nip nip ] } - { "vertex-array" [ drop drop ] } - { "indexes" [ drop nip ] } - } 3 render - ] curry 2each - ] - [ - draw-axes - ] - bi ; - -M: collada-world draw-world* - draw-collada ; - -M: collada-world wasd-movement-speed drop 1/16. ; -M: collada-world wasd-near-plane drop 1/32. ; -M: collada-world wasd-far-plane drop 1024.0 ; - -GAME: collada-game { - { world-class collada-world } - { title "Collada Viewer" } - { pixel-format-attributes { - windowed - double-buffered - } } - { grab-input? t } - { use-game-input? t } - { pref-dim { 1024 768 } } - { tick-interval-micros $[ 60 fps ] } - } ; diff --git a/basis/combinators/short-circuit/short-circuit-tests.factor b/basis/combinators/short-circuit/short-circuit-tests.factor index b2bcb2a60f..3495555062 100644 --- a/basis/combinators/short-circuit/short-circuit-tests.factor +++ b/basis/combinators/short-circuit/short-circuit-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math tools.test combinators.short-circuit ; +USING: kernel math tools.test combinators.short-circuit accessors ; IN: combinators.short-circuit.tests [ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test @@ -22,4 +22,19 @@ IN: combinators.short-circuit.tests : compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ; [ 30 ] [ 10 20 compiled-|| ] unit-test -[ 2 ] [ 1 1 compiled-|| ] unit-test \ No newline at end of file +[ 2 ] [ 1 1 compiled-|| ] unit-test + +! && and || should be row-polymorphic both when compiled and when interpreted + +: row-&& ( -- ? ) + f t { [ drop dup ] } 1&& nip ; + +[ f ] [ row-&& ] unit-test +[ f ] [ \ row-&& def>> call ] unit-test + +: row-|| ( -- ? ) + f t { [ drop dup ] } 1|| nip ; + +[ f ] [ row-|| ] unit-test +[ f ] [ \ row-|| def>> call ] unit-test + diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index dabbe07afb..284e2a60d4 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -1,11 +1,19 @@ USING: kernel combinators quotations arrays sequences assocs -generalizations macros fry ; +generalizations macros fry math ; IN: combinators.short-circuit + + MACRO: n&& ( quots n -- quot ) [ [ [ f ] ] 2dip swap [ - [ '[ drop _ ndup @ dup not ] ] + [ '[ drop _ _ keeping dup not ] ] [ drop '[ drop _ ndrop f ] ] 2bi 2array ] with map @@ -27,7 +35,7 @@ PRIVATE> MACRO: n|| ( quots n -- quot ) [ [ [ f ] ] 2dip swap [ - [ '[ drop _ ndup @ dup ] ] + [ '[ drop _ _ keeping dup ] ] [ drop '[ _ nnip ] ] 2bi 2array ] with map diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 3ad5b6c7ee..5576421742 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -53,4 +53,4 @@ MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; MACRO: smart-apply ( quot n -- ) - [ dup inputs ] dip '[ _ _ mnapply ] ; + [ dup inputs ] dip '[ _ _ _ mnapply ] ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor old mode 100644 new mode 100755 index ef6794e9fa..963ed0ab28 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -5,7 +5,7 @@ kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.strings alien.arrays alien.complex alien.libraries sets libc continuations.private fry cpu.architecture classes classes.struct locals -source-files.errors slots parser generic.parser +source-files.errors slots parser generic.parser strings compiler.errors compiler.alien compiler.constants @@ -24,24 +24,12 @@ H{ } clone insn-counts set-global GENERIC: generate-insn ( insn -- ) -TUPLE: asm label code calls ; - -SYMBOL: calls - -: add-call ( word -- ) - #! Compile this word later. - calls get push ; - ! Mapping _label IDs to label instances SYMBOL: labels -: init-generator ( -- ) - H{ } clone labels set - V{ } clone calls set ; - -: generate-insns ( asm -- code ) +: generate ( mr -- code ) dup label>> [ - init-generator + H{ } clone labels set instructions>> [ [ class insn-counts get inc-at ] [ generate-insn ] @@ -49,22 +37,12 @@ SYMBOL: labels ] each ] with-fixup ; -: generate ( mr -- asm ) - [ - [ label>> ] [ generate-insns ] bi calls get - asm boa - ] with-scope ; - : lookup-label ( id -- label ) labels get [ drop