From 98da7ac16e81edc926e090fbdff0534f9b658bbb Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Tue, 2 Mar 2010 19:32:07 -0800 Subject: [PATCH 01/52] FUEL syntax updates --- misc/fuel/fuel-syntax.el | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 67a8ee89e0..114355b3db 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -57,6 +57,7 @@ "LIBRARY:" "M:" "M::" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:" + "NAN:" "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" "QUALIFIED-WITH:" "QUALIFIED:" @@ -64,7 +65,7 @@ "SINGLETON:" "SINGLETONS:" "SLOT:" "SPECIALIZED-ARRAY:" "SPECIALIZED-ARRAYS:" "STRING:" "STRUCT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:" "TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::" "UNIFORM-TUPLE:" "UNION:" "UNION-STRUCT:" "USE:" "USING:" - "VARS:" "VERTEX-FORMAT:")) + "VARIANT:" "VERTEX-FORMAT:")) (defconst fuel-syntax--parsing-words-regex (regexp-opt fuel-syntax--parsing-words 'words)) @@ -91,7 +92,7 @@ "\\_<-?[0-9]+\\_>") (defconst fuel-syntax--raw-float-regex - "[0-9]*\\.[0-9]*\\([eE][+-]?[0-9]+\\)?") + "[0-9]*\\.[0-9]*\\([eEpP][+-]?[0-9]+\\)?") (defconst fuel-syntax--float-regex (format "\\_<-?%s\\_>" fuel-syntax--raw-float-regex)) @@ -121,7 +122,7 @@ '("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:"))) (defconst fuel-syntax--int-constant-def-regex - (fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "OCT:"))) + (fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "NAN:" "OCT:"))) (defconst fuel-syntax--type-definition-regex (fuel-syntax--second-word-regex @@ -163,18 +164,16 @@ "MEMO" "MEMO:" "METHOD" "SYNTAX" "PREDICATE" "PRIMITIVE" - "STRUCT" "TAG" "TUPLE" + "SINGLETONS" + "STRUCT" "SYMBOLS" "TAG" "TUPLE" "TYPED" "TYPED:" "UNIFORM-TUPLE" "UNION-STRUCT" "UNION" - "VERTEX-FORMAT")) + "VARIANT" "VERTEX-FORMAT")) (defconst fuel-syntax--no-indent-def-starts '("ARTICLE" "HELP" - "SINGLETONS" - "SPECIALIZED-ARRAYS" - "SYMBOLS" - "VARS")) + "SPECIALIZED-ARRAYS")) (defconst fuel-syntax--indent-def-start-regex (format "^\\(%s:\\)\\( \\|\n\\)" (regexp-opt fuel-syntax--indent-def-starts))) @@ -198,6 +197,7 @@ "IN:" "INSTANCE:" "LIBRARY:" "MAIN:" "MATH:" "MIXIN:" + "NAN:" "OCT:" "POSTPONE:" "PRIVATE>" "\\)" (1 "\\)" + ("\\_<\\(SYMBOLS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\|VARIANT\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)" (2 "" (1 ">b")) ;; Let and lambda: From a7f1d4f231b7977f889a4adb249a3ac8bcebf037 Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Wed, 3 Mar 2010 00:02:47 -0800 Subject: [PATCH 02/52] Initial checkin of OpenCL bindings --- extra/opencl/authors.txt | 1 + extra/opencl/ffi/authors.txt | 1 + extra/opencl/ffi/ffi-tests.factor | 74 ++++ extra/opencl/ffi/ffi.factor | 618 ++++++++++++++++++++++++++++++ extra/opencl/ffi/summary.txt | 1 + extra/opencl/ffi/tags.txt | 1 + extra/opencl/opencl-docs.factor | 246 ++++++++++++ extra/opencl/opencl-tests.factor | 44 +++ extra/opencl/opencl.factor | 572 +++++++++++++++++++++++++++ extra/opencl/summary.txt | 1 + extra/opencl/syntax/authors.txt | 1 + extra/opencl/syntax/syntax.factor | 8 + extra/opencl/tags.txt | 1 + 13 files changed, 1569 insertions(+) create mode 100644 extra/opencl/authors.txt create mode 100644 extra/opencl/ffi/authors.txt create mode 100644 extra/opencl/ffi/ffi-tests.factor create mode 100644 extra/opencl/ffi/ffi.factor create mode 100644 extra/opencl/ffi/summary.txt create mode 100644 extra/opencl/ffi/tags.txt create mode 100644 extra/opencl/opencl-docs.factor create mode 100644 extra/opencl/opencl-tests.factor create mode 100644 extra/opencl/opencl.factor create mode 100644 extra/opencl/summary.txt create mode 100644 extra/opencl/syntax/authors.txt create mode 100644 extra/opencl/syntax/syntax.factor create mode 100644 extra/opencl/tags.txt diff --git a/extra/opencl/authors.txt b/extra/opencl/authors.txt new file mode 100644 index 0000000000..6f03a12101 --- /dev/null +++ b/extra/opencl/authors.txt @@ -0,0 +1 @@ +Erik Charlebois diff --git a/extra/opencl/ffi/authors.txt b/extra/opencl/ffi/authors.txt new file mode 100644 index 0000000000..6f03a12101 --- /dev/null +++ b/extra/opencl/ffi/authors.txt @@ -0,0 +1 @@ +Erik Charlebois diff --git a/extra/opencl/ffi/ffi-tests.factor b/extra/opencl/ffi/ffi-tests.factor new file mode 100644 index 0000000000..44bb49ce4e --- /dev/null +++ b/extra/opencl/ffi/ffi-tests.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test opencl.ffi multiline locals kernel io.encodings.ascii +io.encodings.string sequences libc alien.c-types destructors math specialized-arrays +math.order alien ; +FROM: alien.c-types => float ; +SPECIALIZED-ARRAY: float +IN: opencl.ffi.tests + +STRING: kernel-source +__kernel square( + __global float* input, + __global float* output, + const unsigned int count) +{ + int i = get_global_id(0); + if (i < count) + output[i] = input[i] * input[i]; +} +; + +ERROR: cl-error err ; +: cl-success ( err -- ) + dup CL_SUCCESS = [ drop ] [ cl-error ] if ; + +:: cl-string-array ( str -- alien ) + str ascii encode 0 suffix :> str-buffer + str-buffer length malloc &free :> str-alien + str-alien str-buffer dup length memcpy str-alien ; + +:: opencl-square ( in type -- out ) + f CL_DEVICE_TYPE_CPU 1 f [ f clGetDeviceIDs cl-success ] keep *void* :> device-id + f 1 device-id f f 0 [ clCreateContext ] keep *int cl-success :> context + context device-id 0 0 [ clCreateCommandQueue ] keep *int cl-success :> queue + + [ + context 1 kernel-source cl-string-array + f 0 [ clCreateProgramWithSource ] keep *int cl-success + [ 0 f f f f clBuildProgram cl-success ] + [ "square" cl-string-array 0 [ clCreateKernel ] keep *int cl-success ] + [ ] tri + ] with-destructors :> ( kernel program ) + + context CL_MEM_READ_ONLY in byte-length f + 0 [ clCreateBuffer ] keep *int cl-success :> input + + context CL_MEM_WRITE_ONLY in byte-length f + 0 [ clCreateBuffer ] keep *int cl-success :> output + + queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success + + kernel 0 cl_mem heap-size input clSetKernelArg cl-success + kernel 1 cl_mem heap-size output clSetKernelArg cl-success + kernel 2 uint heap-size in length clSetKernelArg cl-success + + queue kernel 1 f in length f + 0 f f clEnqueueNDRangeKernel cl-success + + queue clFinish cl-success + + queue output CL_TRUE 0 in byte-length in length + [ 0 f f clEnqueueReadBuffer cl-success ] keep + + input clReleaseMemObject cl-success + output clReleaseMemObject cl-success + program clReleaseProgram cl-success + kernel clReleaseKernel cl-success + queue clReleaseCommandQueue cl-success + context clReleaseContext cl-success ; + +[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ] +[ float-array{ 1.0 2.0 3.0 4.0 10.0 } CL_DEVICE_TYPE_CPU opencl-square ] unit-test +[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ] +[ float-array{ 1.0 2.0 3.0 4.0 10.0 } CL_DEVICE_TYPE_GPU opencl-square ] unit-test diff --git a/extra/opencl/ffi/ffi.factor b/extra/opencl/ffi/ffi.factor new file mode 100644 index 0000000000..36f1c13519 --- /dev/null +++ b/extra/opencl/ffi/ffi.factor @@ -0,0 +1,618 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types alien.libraries alien.syntax classes.struct +combinators system unix.types alien.accessors byte-arrays kernel ; +IN: opencl.ffi + +<< "opencl" { + { [ os windows? ] [ "OpenCL32.dll" ] } + { [ os macosx? ] [ "/System/Library/Frameworks/OpenCL.framework/OpenCL" ] } + { [ os unix? ] [ "libopencl.so" ] } + } cond "stdcall" add-library >> +LIBRARY: opencl + +! cl_platform.h +TYPEDEF: int8_t cl_char +TYPEDEF: uint8_t cl_uchar +TYPEDEF: int16_t cl_short +TYPEDEF: uint16_t cl_ushort +TYPEDEF: int32_t cl_int +TYPEDEF: uint32_t cl_uint +TYPEDEF: int64_t cl_long +TYPEDEF: uint64_t cl_ulong +TYPEDEF: uint16_t cl_half; +TYPEDEF: float cl_float; +TYPEDEF: double cl_double; + +CONSTANT: CL_CHAR_BIT 8 +CONSTANT: CL_SCHAR_MAX 127 +CONSTANT: CL_SCHAR_MIN -128 +CONSTANT: CL_CHAR_MAX 127 +CONSTANT: CL_CHAR_MIN -128 +CONSTANT: CL_UCHAR_MAX 255 +CONSTANT: CL_SHRT_MAX 32767 +CONSTANT: CL_SHRT_MIN -32768 +CONSTANT: CL_USHRT_MAX 65535 +CONSTANT: CL_INT_MAX 2147483647 +CONSTANT: CL_INT_MIN -2147483648 +CONSTANT: CL_UINT_MAX HEX: ffffffff +CONSTANT: CL_LONG_MAX HEX: 7FFFFFFFFFFFFFFF +CONSTANT: CL_LONG_MIN HEX: 8000000000000000 +CONSTANT: CL_ULONG_MAX HEX: FFFFFFFFFFFFFFFF + +CONSTANT: CL_FLT_DIG 6 +CONSTANT: CL_FLT_MANT_DIG 24 +CONSTANT: CL_FLT_MAX_10_EXP 38 +CONSTANT: CL_FLT_MAX_EXP 128 +CONSTANT: CL_FLT_MIN_10_EXP -37 +CONSTANT: CL_FLT_MIN_EXP -125 +CONSTANT: CL_FLT_RADIX 2 +CONSTANT: CL_FLT_MAX 340282346638528859811704183484516925440.0 +CONSTANT: CL_FLT_MIN 1.175494350822287507969e-38 +CONSTANT: CL_FLT_EPSILON HEX: 1.0p-23 + +CONSTANT: CL_DBL_DIG 15 +CONSTANT: CL_DBL_MANT_DIG 53 +CONSTANT: CL_DBL_MAX_10_EXP 308 +CONSTANT: CL_DBL_MAX_EXP 1024 +CONSTANT: CL_DBL_MIN_10_EXP -307 +CONSTANT: CL_DBL_MIN_EXP -1021 +CONSTANT: CL_DBL_RADIX 2 +CONSTANT: CL_DBL_MAX 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0 +CONSTANT: CL_DBL_MIN 2.225073858507201383090e-308 +CONSTANT: CL_DBL_EPSILON 2.220446049250313080847e-16 + +CONSTANT: CL_NAN NAN: 0 +CONSTANT: CL_HUGE_VALF 1.0e50 +CONSTANT: CL_HUGE_VAL 1.0e500 +CONSTANT: CL_MAXFLOAT 340282346638528859811704183484516925440.0 +CONSTANT: CL_INFINITY 1.0e50 + +TYPEDEF: uint cl_GLuint +TYPEDEF: int cl_GLint +TYPEDEF: uint cl_GLenum + +! cl.h +C-TYPE: _cl_platform_id +C-TYPE: _cl_device_id +C-TYPE: _cl_context +C-TYPE: _cl_command_queue +C-TYPE: _cl_mem +C-TYPE: _cl_program +C-TYPE: _cl_kernel +C-TYPE: _cl_event +C-TYPE: _cl_sampler + +TYPEDEF: _cl_platform_id* cl_platform_id +TYPEDEF: _cl_device_id* cl_device_id +TYPEDEF: _cl_context* cl_context +TYPEDEF: _cl_command_queue* cl_command_queue +TYPEDEF: _cl_mem* cl_mem +TYPEDEF: _cl_program* cl_program +TYPEDEF: _cl_kernel* cl_kernel +TYPEDEF: _cl_event* cl_event +TYPEDEF: _cl_sampler* cl_sampler + +TYPEDEF: cl_uint cl_bool +TYPEDEF: cl_ulong cl_bitfield +TYPEDEF: cl_bitfield cl_device_type +TYPEDEF: cl_uint cl_platform_info +TYPEDEF: cl_uint cl_device_info +TYPEDEF: cl_bitfield cl_device_address_info +TYPEDEF: cl_bitfield cl_device_fp_config +TYPEDEF: cl_uint cl_device_mem_cache_type +TYPEDEF: cl_uint cl_device_local_mem_type +TYPEDEF: cl_bitfield cl_device_exec_capabilities +TYPEDEF: cl_bitfield cl_command_queue_properties + +TYPEDEF: intptr_t cl_context_properties +TYPEDEF: cl_uint cl_context_info +TYPEDEF: cl_uint cl_command_queue_info +TYPEDEF: cl_uint cl_channel_order +TYPEDEF: cl_uint cl_channel_type +TYPEDEF: cl_bitfield cl_mem_flags +TYPEDEF: cl_uint cl_mem_object_type +TYPEDEF: cl_uint cl_mem_info +TYPEDEF: cl_uint cl_image_info +TYPEDEF: cl_uint cl_addressing_mode +TYPEDEF: cl_uint cl_filter_mode +TYPEDEF: cl_uint cl_sampler_info +TYPEDEF: cl_bitfield cl_map_flags +TYPEDEF: cl_uint cl_program_info +TYPEDEF: cl_uint cl_program_build_info +TYPEDEF: cl_int cl_build_status +TYPEDEF: cl_uint cl_kernel_info +TYPEDEF: cl_uint cl_kernel_work_group_info +TYPEDEF: cl_uint cl_event_info +TYPEDEF: cl_uint cl_command_type +TYPEDEF: cl_uint cl_profiling_info + +STRUCT: cl_image_format + { image_channel_order cl_channel_order } + { image_channel_data_type cl_channel_type } ; + +CONSTANT: CL_SUCCESS 0 +CONSTANT: CL_DEVICE_NOT_FOUND -1 +CONSTANT: CL_DEVICE_NOT_AVAILABLE -2 +CONSTANT: CL_COMPILER_NOT_AVAILABLE -3 +CONSTANT: CL_MEM_OBJECT_ALLOCATION_FAILURE -4 +CONSTANT: CL_OUT_OF_RESOURCES -5 +CONSTANT: CL_OUT_OF_HOST_MEMORY -6 +CONSTANT: CL_PROFILING_INFO_NOT_AVAILABLE -7 +CONSTANT: CL_MEM_COPY_OVERLAP -8 +CONSTANT: CL_IMAGE_FORMAT_MISMATCH -9 +CONSTANT: CL_IMAGE_FORMAT_NOT_SUPPORTED -10 +CONSTANT: CL_BUILD_PROGRAM_FAILURE -11 +CONSTANT: CL_MAP_FAILURE -12 + +CONSTANT: CL_INVALID_VALUE -30 +CONSTANT: CL_INVALID_DEVICE_TYPE -31 +CONSTANT: CL_INVALID_PLATFORM -32 +CONSTANT: CL_INVALID_DEVICE -33 +CONSTANT: CL_INVALID_CONTEXT -34 +CONSTANT: CL_INVALID_QUEUE_PROPERTIES -35 +CONSTANT: CL_INVALID_COMMAND_QUEUE -36 +CONSTANT: CL_INVALID_HOST_PTR -37 +CONSTANT: CL_INVALID_MEM_OBJECT -38 +CONSTANT: CL_INVALID_IMAGE_FORMAT_DESCRIPTOR -39 +CONSTANT: CL_INVALID_IMAGE_SIZE -40 +CONSTANT: CL_INVALID_SAMPLER -41 +CONSTANT: CL_INVALID_BINARY -42 +CONSTANT: CL_INVALID_BUILD_OPTIONS -43 +CONSTANT: CL_INVALID_PROGRAM -44 +CONSTANT: CL_INVALID_PROGRAM_EXECUTABLE -45 +CONSTANT: CL_INVALID_KERNEL_NAME -46 +CONSTANT: CL_INVALID_KERNEL_DEFINITION -47 +CONSTANT: CL_INVALID_KERNEL -48 +CONSTANT: CL_INVALID_ARG_INDEX -49 +CONSTANT: CL_INVALID_ARG_VALUE -50 +CONSTANT: CL_INVALID_ARG_SIZE -51 +CONSTANT: CL_INVALID_KERNEL_ARGS -52 +CONSTANT: CL_INVALID_WORK_DIMENSION -53 +CONSTANT: CL_INVALID_WORK_GROUP_SIZE -54 +CONSTANT: CL_INVALID_WORK_ITEM_SIZE -55 +CONSTANT: CL_INVALID_GLOBAL_OFFSET -56 +CONSTANT: CL_INVALID_EVENT_WAIT_LIST -57 +CONSTANT: CL_INVALID_EVENT -58 +CONSTANT: CL_INVALID_OPERATION -59 +CONSTANT: CL_INVALID_GL_OBJECT -60 +CONSTANT: CL_INVALID_BUFFER_SIZE -61 +CONSTANT: CL_INVALID_MIP_LEVEL -62 +CONSTANT: CL_INVALID_GLOBAL_WORK_SIZE -63 + +CONSTANT: CL_VERSION_1_0 1 + +CONSTANT: CL_FALSE 0 +CONSTANT: CL_TRUE 1 + +CONSTANT: CL_PLATFORM_PROFILE HEX: 0900 +CONSTANT: CL_PLATFORM_VERSION HEX: 0901 +CONSTANT: CL_PLATFORM_NAME HEX: 0902 +CONSTANT: CL_PLATFORM_VENDOR HEX: 0903 +CONSTANT: CL_PLATFORM_EXTENSIONS HEX: 0904 + +CONSTANT: CL_DEVICE_TYPE_DEFAULT 1 +CONSTANT: CL_DEVICE_TYPE_CPU 2 +CONSTANT: CL_DEVICE_TYPE_GPU 4 +CONSTANT: CL_DEVICE_TYPE_ACCELERATOR 8 +CONSTANT: CL_DEVICE_TYPE_ALL HEX: FFFFFFFF + +CONSTANT: CL_DEVICE_TYPE HEX: 1000 +CONSTANT: CL_DEVICE_VENDOR_ID HEX: 1001 +CONSTANT: CL_DEVICE_MAX_COMPUTE_UNITS HEX: 1002 +CONSTANT: CL_DEVICE_MAX_WORK_ITEM_DIMENSIONS HEX: 1003 +CONSTANT: CL_DEVICE_MAX_WORK_GROUP_SIZE HEX: 1004 +CONSTANT: CL_DEVICE_MAX_WORK_ITEM_SIZES HEX: 1005 +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_CHAR HEX: 1006 +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_SHORT HEX: 1007 +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_INT HEX: 1008 +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_LONG HEX: 1009 +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT HEX: 100A +CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE HEX: 100B +CONSTANT: CL_DEVICE_MAX_CLOCK_FREQUENCY HEX: 100C +CONSTANT: CL_DEVICE_ADDRESS_BITS HEX: 100D +CONSTANT: CL_DEVICE_MAX_READ_IMAGE_ARGS HEX: 100E +CONSTANT: CL_DEVICE_MAX_WRITE_IMAGE_ARGS HEX: 100F +CONSTANT: CL_DEVICE_MAX_MEM_ALLOC_SIZE HEX: 1010 +CONSTANT: CL_DEVICE_IMAGE2D_MAX_WIDTH HEX: 1011 +CONSTANT: CL_DEVICE_IMAGE2D_MAX_HEIGHT HEX: 1012 +CONSTANT: CL_DEVICE_IMAGE3D_MAX_WIDTH HEX: 1013 +CONSTANT: CL_DEVICE_IMAGE3D_MAX_HEIGHT HEX: 1014 +CONSTANT: CL_DEVICE_IMAGE3D_MAX_DEPTH HEX: 1015 +CONSTANT: CL_DEVICE_IMAGE_SUPPORT HEX: 1016 +CONSTANT: CL_DEVICE_MAX_PARAMETER_SIZE HEX: 1017 +CONSTANT: CL_DEVICE_MAX_SAMPLERS HEX: 1018 +CONSTANT: CL_DEVICE_MEM_BASE_ADDR_ALIGN HEX: 1019 +CONSTANT: CL_DEVICE_MIN_DATA_TYPE_ALIGN_SIZE HEX: 101A +CONSTANT: CL_DEVICE_SINGLE_FP_CONFIG HEX: 101B +CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHE_TYPE HEX: 101C +CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHELINE_SIZE HEX: 101D +CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHE_SIZE HEX: 101E +CONSTANT: CL_DEVICE_GLOBAL_MEM_SIZE HEX: 101F +CONSTANT: CL_DEVICE_MAX_CONSTANT_BUFFER_SIZE HEX: 1020 +CONSTANT: CL_DEVICE_MAX_CONSTANT_ARGS HEX: 1021 +CONSTANT: CL_DEVICE_LOCAL_MEM_TYPE HEX: 1022 +CONSTANT: CL_DEVICE_LOCAL_MEM_SIZE HEX: 1023 +CONSTANT: CL_DEVICE_ERROR_CORRECTION_SUPPORT HEX: 1024 +CONSTANT: CL_DEVICE_PROFILING_TIMER_RESOLUTION HEX: 1025 +CONSTANT: CL_DEVICE_ENDIAN_LITTLE HEX: 1026 +CONSTANT: CL_DEVICE_AVAILABLE HEX: 1027 +CONSTANT: CL_DEVICE_COMPILER_AVAILABLE HEX: 1028 +CONSTANT: CL_DEVICE_EXECUTION_CAPABILITIES HEX: 1029 +CONSTANT: CL_DEVICE_QUEUE_PROPERTIES HEX: 102A +CONSTANT: CL_DEVICE_NAME HEX: 102B +CONSTANT: CL_DEVICE_VENDOR HEX: 102C +CONSTANT: CL_DRIVER_VERSION HEX: 102D +CONSTANT: CL_DEVICE_PROFILE HEX: 102E +CONSTANT: CL_DEVICE_VERSION HEX: 102F +CONSTANT: CL_DEVICE_EXTENSIONS HEX: 1030 +CONSTANT: CL_DEVICE_PLATFORM HEX: 1031 + +CONSTANT: CL_FP_DENORM 1 +CONSTANT: CL_FP_INF_NAN 2 +CONSTANT: CL_FP_ROUND_TO_NEAREST 4 +CONSTANT: CL_FP_ROUND_TO_ZERO 8 +CONSTANT: CL_FP_ROUND_TO_INF 16 +CONSTANT: CL_FP_FMA 32 + +CONSTANT: CL_NONE 0 +CONSTANT: CL_READ_ONLY_CACHE 1 +CONSTANT: CL_READ_WRITE_CACHE 2 + +CONSTANT: CL_LOCAL 1 +CONSTANT: CL_GLOBAL 2 + +CONSTANT: CL_EXEC_KERNEL 1 +CONSTANT: CL_EXEC_NATIVE_KERNEL 2 + +CONSTANT: CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE 1 +CONSTANT: CL_QUEUE_PROFILING_ENABLE 2 + +CONSTANT: CL_CONTEXT_REFERENCE_COUNT HEX: 1080 +CONSTANT: CL_CONTEXT_DEVICES HEX: 1081 +CONSTANT: CL_CONTEXT_PROPERTIES HEX: 1082 + +CONSTANT: CL_CONTEXT_PLATFORM HEX: 1084 + +CONSTANT: CL_QUEUE_CONTEXT HEX: 1090 +CONSTANT: CL_QUEUE_DEVICE HEX: 1091 +CONSTANT: CL_QUEUE_REFERENCE_COUNT HEX: 1092 +CONSTANT: CL_QUEUE_PROPERTIES HEX: 1093 + +CONSTANT: CL_MEM_READ_WRITE 1 +CONSTANT: CL_MEM_WRITE_ONLY 2 +CONSTANT: CL_MEM_READ_ONLY 4 +CONSTANT: CL_MEM_USE_HOST_PTR 8 +CONSTANT: CL_MEM_ALLOC_HOST_PTR 16 +CONSTANT: CL_MEM_COPY_HOST_PTR 32 + +CONSTANT: CL_R HEX: 10B0 +CONSTANT: CL_A HEX: 10B1 +CONSTANT: CL_RG HEX: 10B2 +CONSTANT: CL_RA HEX: 10B3 +CONSTANT: CL_RGB HEX: 10B4 +CONSTANT: CL_RGBA HEX: 10B5 +CONSTANT: CL_BGRA HEX: 10B6 +CONSTANT: CL_ARGB HEX: 10B7 +CONSTANT: CL_INTENSITY HEX: 10B8 +CONSTANT: CL_LUMINANCE HEX: 10B9 + +CONSTANT: CL_SNORM_INT8 HEX: 10D0 +CONSTANT: CL_SNORM_INT16 HEX: 10D1 +CONSTANT: CL_UNORM_INT8 HEX: 10D2 +CONSTANT: CL_UNORM_INT16 HEX: 10D3 +CONSTANT: CL_UNORM_SHORT_565 HEX: 10D4 +CONSTANT: CL_UNORM_SHORT_555 HEX: 10D5 +CONSTANT: CL_UNORM_INT_101010 HEX: 10D6 +CONSTANT: CL_SIGNED_INT8 HEX: 10D7 +CONSTANT: CL_SIGNED_INT16 HEX: 10D8 +CONSTANT: CL_SIGNED_INT32 HEX: 10D9 +CONSTANT: CL_UNSIGNED_INT8 HEX: 10DA +CONSTANT: CL_UNSIGNED_INT16 HEX: 10DB +CONSTANT: CL_UNSIGNED_INT32 HEX: 10DC +CONSTANT: CL_HALF_FLOAT HEX: 10DD +CONSTANT: CL_FLOAT HEX: 10DE + +CONSTANT: CL_MEM_OBJECT_BUFFER HEX: 10F0 +CONSTANT: CL_MEM_OBJECT_IMAGE2D HEX: 10F1 +CONSTANT: CL_MEM_OBJECT_IMAGE3D HEX: 10F2 + +CONSTANT: CL_MEM_TYPE HEX: 1100 +CONSTANT: CL_MEM_FLAGS HEX: 1101 +CONSTANT: CL_MEM_SIZE HEX: 1102 +CONSTANT: CL_MEM_HOST_PTR HEX: 1103 +CONSTANT: CL_MEM_MAP_COUNT HEX: 1104 +CONSTANT: CL_MEM_REFERENCE_COUNT HEX: 1105 +CONSTANT: CL_MEM_CONTEXT HEX: 1106 + +CONSTANT: CL_IMAGE_FORMAT HEX: 1110 +CONSTANT: CL_IMAGE_ELEMENT_SIZE HEX: 1111 +CONSTANT: CL_IMAGE_ROW_PITCH HEX: 1112 +CONSTANT: CL_IMAGE_SLICE_PITCH HEX: 1113 +CONSTANT: CL_IMAGE_WIDTH HEX: 1114 +CONSTANT: CL_IMAGE_HEIGHT HEX: 1115 +CONSTANT: CL_IMAGE_DEPTH HEX: 1116 + +CONSTANT: CL_ADDRESS_NONE HEX: 1130 +CONSTANT: CL_ADDRESS_CLAMP_TO_EDGE HEX: 1131 +CONSTANT: CL_ADDRESS_CLAMP HEX: 1132 +CONSTANT: CL_ADDRESS_REPEAT HEX: 1133 + +CONSTANT: CL_FILTER_NEAREST HEX: 1140 +CONSTANT: CL_FILTER_LINEAR HEX: 1141 + +CONSTANT: CL_SAMPLER_REFERENCE_COUNT HEX: 1150 +CONSTANT: CL_SAMPLER_CONTEXT HEX: 1151 +CONSTANT: CL_SAMPLER_NORMALIZED_COORDS HEX: 1152 +CONSTANT: CL_SAMPLER_ADDRESSING_MODE HEX: 1153 +CONSTANT: CL_SAMPLER_FILTER_MODE HEX: 1154 + +CONSTANT: CL_MAP_READ 1 +CONSTANT: CL_MAP_WRITE 2 + +CONSTANT: CL_PROGRAM_REFERENCE_COUNT HEX: 1160 +CONSTANT: CL_PROGRAM_CONTEXT HEX: 1161 +CONSTANT: CL_PROGRAM_NUM_DEVICES HEX: 1162 +CONSTANT: CL_PROGRAM_DEVICES HEX: 1163 +CONSTANT: CL_PROGRAM_SOURCE HEX: 1164 +CONSTANT: CL_PROGRAM_BINARY_SIZES HEX: 1165 +CONSTANT: CL_PROGRAM_BINARIES HEX: 1166 + +CONSTANT: CL_PROGRAM_BUILD_STATUS HEX: 1181 +CONSTANT: CL_PROGRAM_BUILD_OPTIONS HEX: 1182 +CONSTANT: CL_PROGRAM_BUILD_LOG HEX: 1183 + +CONSTANT: CL_BUILD_SUCCESS 0 +CONSTANT: CL_BUILD_NONE -1 +CONSTANT: CL_BUILD_ERROR -2 +CONSTANT: CL_BUILD_IN_PROGRESS -3 + +CONSTANT: CL_KERNEL_FUNCTION_NAME HEX: 1190 +CONSTANT: CL_KERNEL_NUM_ARGS HEX: 1191 +CONSTANT: CL_KERNEL_REFERENCE_COUNT HEX: 1192 +CONSTANT: CL_KERNEL_CONTEXT HEX: 1193 +CONSTANT: CL_KERNEL_PROGRAM HEX: 1194 + +CONSTANT: CL_KERNEL_WORK_GROUP_SIZE HEX: 11B0 +CONSTANT: CL_KERNEL_COMPILE_WORK_GROUP_SIZE HEX: 11B1 +CONSTANT: CL_KERNEL_LOCAL_MEM_SIZE HEX: 11B2 + +CONSTANT: CL_EVENT_COMMAND_QUEUE HEX: 11D0 +CONSTANT: CL_EVENT_COMMAND_TYPE HEX: 11D1 +CONSTANT: CL_EVENT_REFERENCE_COUNT HEX: 11D2 +CONSTANT: CL_EVENT_COMMAND_EXECUTION_STATUS HEX: 11D3 + +CONSTANT: CL_COMMAND_NDRANGE_KERNEL HEX: 11F0 +CONSTANT: CL_COMMAND_TASK HEX: 11F1 +CONSTANT: CL_COMMAND_NATIVE_KERNEL HEX: 11F2 +CONSTANT: CL_COMMAND_READ_BUFFER HEX: 11F3 +CONSTANT: CL_COMMAND_WRITE_BUFFER HEX: 11F4 +CONSTANT: CL_COMMAND_COPY_BUFFER HEX: 11F5 +CONSTANT: CL_COMMAND_READ_IMAGE HEX: 11F6 +CONSTANT: CL_COMMAND_WRITE_IMAGE HEX: 11F7 +CONSTANT: CL_COMMAND_COPY_IMAGE HEX: 11F8 +CONSTANT: CL_COMMAND_COPY_IMAGE_TO_BUFFER HEX: 11F9 +CONSTANT: CL_COMMAND_COPY_BUFFER_TO_IMAGE HEX: 11FA +CONSTANT: CL_COMMAND_MAP_BUFFER HEX: 11FB +CONSTANT: CL_COMMAND_MAP_IMAGE HEX: 11FC +CONSTANT: CL_COMMAND_UNMAP_MEM_OBJECT HEX: 11FD +CONSTANT: CL_COMMAND_MARKER HEX: 11FE +CONSTANT: CL_COMMAND_ACQUIRE_GL_OBJECTS HEX: 11FF +CONSTANT: CL_COMMAND_RELEASE_GL_OBJECTS HEX: 1200 + +CONSTANT: CL_COMPLETE HEX: 0 +CONSTANT: CL_RUNNING HEX: 1 +CONSTANT: CL_SUBMITTED HEX: 2 +CONSTANT: CL_QUEUED HEX: 3 + +CONSTANT: CL_PROFILING_COMMAND_QUEUED HEX: 1280 +CONSTANT: CL_PROFILING_COMMAND_SUBMIT HEX: 1281 +CONSTANT: CL_PROFILING_COMMAND_START HEX: 1282 +CONSTANT: CL_PROFILING_COMMAND_END HEX: 1283 + +FUNCTION: cl_int clGetPlatformIDs ( cl_uint num_entries, cl_platform_id* platforms, cl_uint* num_platforms ) ; +FUNCTION: cl_int clGetPlatformInfo ( cl_platform_id platform, cl_platform_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clGetDeviceIDs ( cl_platform_id platform, cl_device_type device_type, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ; +FUNCTION: cl_int clGetDeviceInfo ( cl_device_id device, cl_device_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +CALLBACK: void cl_create_context_cb ( char* a, void* b, size_t s, void* c ) ; +FUNCTION: cl_context clCreateContext ( cl_context_properties* properties, cl_uint num_devices, cl_device_id* devices, cl_create_context_cb pfn_notify, void* user_data, cl_int* errcode_ret ) ; +FUNCTION: cl_context clCreateContextFromType ( cl_context_properties* properties, cl_device_type device_type, cl_create_context_cb pfn_notify, void* user_data, cl_int* errcode_ret ) ; +FUNCTION: cl_int clRetainContext ( cl_context context ) ; +FUNCTION: cl_int clReleaseContext ( cl_context context ) ; +FUNCTION: cl_int clGetContextInfo ( cl_context context, cl_context_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_command_queue clCreateCommandQueue ( cl_context context, cl_device_id device, cl_command_queue_properties properties, cl_int* errcode_ret ) ; +FUNCTION: cl_int clRetainCommandQueue ( cl_command_queue command_queue ) ; +FUNCTION: cl_int clReleaseCommandQueue ( cl_command_queue command_queue ) ; +FUNCTION: cl_int clGetCommandQueueInfo ( cl_command_queue command_queue, cl_command_queue_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clSetCommandQueueProperty ( cl_command_queue command_queue, cl_command_queue_properties properties, cl_bool enable, cl_command_queue_properties* old_properties ) ; +FUNCTION: cl_mem clCreateBuffer ( cl_context context, cl_mem_flags flags, size_t size, void* host_ptr, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateImage2D ( cl_context context, cl_mem_flags flags, cl_image_format* image_format, size_t image_width, size_t image_height, size_t image_row_pitch, void* host_ptr, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateImage3D ( cl_context context, cl_mem_flags flags, cl_image_format* image_format, size_t image_width, size_t image_height, size_t image_depth, size_t image_row_pitch, size_t image_slice_pitch, void* host_ptr, cl_int* errcode_ret ) ; +FUNCTION: cl_int clRetainMemObject ( cl_mem memobj ) ; +FUNCTION: cl_int clReleaseMemObject ( cl_mem memobj ) ; +FUNCTION: cl_int clGetSupportedImageFormats ( cl_context context, cl_mem_flags flags, cl_mem_object_type image_type, cl_uint num_entries, cl_image_format* image_formats, cl_uint* num_image_formats ) ; +FUNCTION: cl_int clGetMemObjectInfo ( cl_mem memobj, cl_mem_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clGetImageInfo ( cl_mem image, cl_image_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_sampler clCreateSampler ( cl_context context, cl_bool normalized_coords, cl_addressing_mode addressing_mode, cl_filter_mode filter_mode, cl_int* errcode_ret ) ; +FUNCTION: cl_int clRetainSampler ( cl_sampler sampler ) ; +FUNCTION: cl_int clReleaseSampler ( cl_sampler sampler ) ; +FUNCTION: cl_int clGetSamplerInfo ( cl_sampler sampler, cl_sampler_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_program clCreateProgramWithSource ( cl_context context, cl_uint count, char** strings, size_t* lengths, cl_int* errcode_ret ) ; +FUNCTION: cl_program clCreateProgramWithBinary ( cl_context context, cl_uint num_devices, cl_device_id* device_list, size_t* lengths, char** binaries, cl_int* binary_status, cl_int* errcode_ret ) ; +FUNCTION: cl_int clRetainProgram ( cl_program program ) ; +FUNCTION: cl_int clReleaseProgram ( cl_program program ) ; +CALLBACK: void cl_build_program_cb ( cl_program program, void* user_data ) ; +FUNCTION: cl_int clBuildProgram ( cl_program program, cl_uint num_devices, cl_device_id* device_list, char* options, cl_build_program_cb pfn_notify, void* user_data ) ; +FUNCTION: cl_int clUnloadCompiler ( ) ; +FUNCTION: cl_int clGetProgramInfo ( cl_program program, cl_program_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clGetProgramBuildInfo ( cl_program program, cl_device_id device, cl_program_build_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_kernel clCreateKernel ( cl_program program, char* kernel_name, cl_int* errcode_ret ) ; +FUNCTION: cl_int clCreateKernelsInProgram ( cl_program program, cl_uint num_kernels, cl_kernel* kernels, cl_uint* num_kernels_ret ) ; +FUNCTION: cl_int clRetainKernel ( cl_kernel kernel ) ; +FUNCTION: cl_int clReleaseKernel ( cl_kernel kernel ) ; +FUNCTION: cl_int clSetKernelArg ( cl_kernel kernel, cl_uint arg_index, size_t arg_size, void* arg_value ) ; +FUNCTION: cl_int clGetKernelInfo ( cl_kernel kernel, cl_kernel_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clGetKernelWorkGroupInfo ( cl_kernel kernel, cl_device_id device, cl_kernel_work_group_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clWaitForEvents ( cl_uint num_events, cl_event* event_list ) ; +FUNCTION: cl_int clGetEventInfo ( cl_event event, cl_event_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clRetainEvent ( cl_event event ) ; +FUNCTION: cl_int clReleaseEvent ( cl_event event ) ; +FUNCTION: cl_int clGetEventProfilingInfo ( cl_event event, cl_profiling_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clFlush ( cl_command_queue command_queue ) ; +FUNCTION: cl_int clFinish ( cl_command_queue command_queue ) ; +FUNCTION: cl_int clEnqueueReadBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_read, size_t offset, size_t cb, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueWriteBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_write, size_t offset, size_t cb, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueCopyBuffer ( cl_command_queue command_queue, cl_mem src_buffer, cl_mem dst_buffer, size_t src_offset, size_t dst_offset, size_t cb, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueReadImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_read, size_t** origin, size_t** region, size_t row_pitch, size_t slice_pitch, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueWriteImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_write, size_t** origin, size_t** region, size_t input_row_pitch, size_t input_slice_pitch, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueCopyImage ( cl_command_queue command_queue, cl_mem src_image, cl_mem dst_image, size_t** src_origin, size_t** dst_origin, size_t** region, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueCopyImageToBuffer ( cl_command_queue command_queue, cl_mem src_image, cl_mem dst_buffer, size_t** src_origin, size_t** region, size_t dst_offset, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueCopyBufferToImage ( cl_command_queue command_queue, cl_mem src_buffer, cl_mem dst_image, size_t src_offset, size_t** dst_origin, size_t** region, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: void* clEnqueueMapBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_map, cl_map_flags map_flags, size_t offset, size_t cb, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event, cl_int* errcode_ret ) ; +FUNCTION: void* clEnqueueMapImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_map, cl_map_flags map_flags, size_t** origin, size_t** region, size_t* image_row_pitch, size_t* image_slice_pitch, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event, cl_int* errcode_ret ) ; +FUNCTION: cl_int clEnqueueUnmapMemObject ( cl_command_queue command_queue, cl_mem memobj, void* mapped_ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueNDRangeKernel ( cl_command_queue command_queue, cl_kernel kernel, cl_uint work_dim, size_t* global_work_offset, size_t* global_work_size, size_t* local_work_size, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +CALLBACK: void cl_enqueue_task_cb ( void* args ) ; +FUNCTION: cl_int clEnqueueTask ( cl_command_queue command_queue, cl_kernel kernel, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueNativeKernel ( cl_command_queue command_queue, cl_enqueue_task_cb user_func, void* args, size_t cb_args, cl_uint num_mem_objects, cl_mem* mem_list, void** args_mem_loc, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueMarker ( cl_command_queue command_queue, cl_event* event ) ; +FUNCTION: cl_int clEnqueueWaitForEvents ( cl_command_queue command_queue, cl_uint num_events, cl_event* event_list ) ; +FUNCTION: cl_int clEnqueueBarrier ( cl_command_queue command_queue ) ; +FUNCTION: void* clGetExtensionFunctionAddress ( char* func_name ) ; + +! cl_ext.h +CONSTANT: CL_DEVICE_DOUBLE_FP_CONFIG HEX: 1032 +CONSTANT: CL_DEVICE_HALF_FP_CONFIG HEX: 1033 + +! cl_khr_icd.txt +CONSTANT: CL_PLATFORM_ICD_SUFFIX_KHR HEX: 0920 +CONSTANT: CL_PLATFORM_NOT_FOUND_KHR -1001 + +FUNCTION: cl_int clIcdGetPlatformIDsKHR ( cl_uint num_entries, cl_platform_id* platforms, cl_uint* num_platforms ) ; + +! cl_gl.h +TYPEDEF: cl_uint cl_gl_object_type +TYPEDEF: cl_uint cl_gl_texture_info +TYPEDEF: cl_uint cl_gl_platform_info + +CONSTANT: CL_GL_OBJECT_BUFFER HEX: 2000 +CONSTANT: CL_GL_OBJECT_TEXTURE2D HEX: 2001 +CONSTANT: CL_GL_OBJECT_TEXTURE3D HEX: 2002 +CONSTANT: CL_GL_OBJECT_RENDERBUFFER HEX: 2003 +CONSTANT: CL_GL_TEXTURE_TARGET HEX: 2004 +CONSTANT: CL_GL_MIPMAP_LEVEL HEX: 2005 + +FUNCTION: cl_mem clCreateFromGLBuffer ( cl_context context, cl_mem_flags flags, cl_GLuint bufobj, int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromGLTexture2D ( cl_context context, cl_mem_flags flags, cl_GLenum target, cl_GLint miplevel, cl_GLuint texture, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromGLTexture3D ( cl_context context, cl_mem_flags flags, cl_GLenum target, cl_GLint miplevel, cl_GLuint texture, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromGLRenderbuffer ( cl_context context, cl_mem_flags flags, cl_GLuint renderbuffer, cl_int* errcode_ret ) ; +FUNCTION: cl_int clGetGLObjectInfo ( cl_mem memobj, cl_gl_object_type* gl_object_type, cl_GLuint* gl_object_name ) ; +FUNCTION: cl_int clGetGLTextureInfo ( cl_mem memobj, cl_gl_texture_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; +FUNCTION: cl_int clEnqueueAcquireGLObjects ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueReleaseGLObjects ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; + +! cl_khr_gl_sharing.txt +TYPEDEF: cl_uint cl_gl_context_info + +CONSTANT: CL_INVALID_GL_SHAREGROUP_REFERENCE_KHR -1000 +CONSTANT: CL_CURRENT_DEVICE_FOR_GL_CONTEXT_KHR HEX: 2006 +CONSTANT: CL_DEVICES_FOR_GL_CONTEXT_KHR HEX: 2007 +CONSTANT: CL_GL_CONTEXT_KHR HEX: 2008 +CONSTANT: CL_EGL_DISPLAY_KHR HEX: 2009 +CONSTANT: CL_GLX_DISPLAY_KHR HEX: 200A +CONSTANT: CL_WGL_HDC_KHR HEX: 200B +CONSTANT: CL_CGL_SHAREGROUP_KHR HEX: 200C + +FUNCTION: cl_int clGetGLContextInfoKHR ( cl_context_properties* properties, cl_gl_context_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ; + +! cl_nv_d3d9_sharing.txt +CONSTANT: CL_D3D9_DEVICE_NV HEX: 4022 +CONSTANT: CL_D3D9_ADAPTER_NAME_NV HEX: 4023 +CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D9_NV HEX: 4024 +CONSTANT: CL_ALL_DEVICES_FOR_D3D9_NV HEX: 4025 +CONSTANT: CL_CONTEXT_D3D9_DEVICE_NV HEX: 4026 +CONSTANT: CL_MEM_D3D9_RESOURCE_NV HEX: 4027 +CONSTANT: CL_IMAGE_D3D9_FACE_NV HEX: 4028 +CONSTANT: CL_IMAGE_D3D9_LEVEL_NV HEX: 4029 +CONSTANT: CL_COMMAND_ACQUIRE_D3D9_OBJECTS_NV HEX: 402A +CONSTANT: CL_COMMAND_RELEASE_D3D9_OBJECTS_NV HEX: 402B +CONSTANT: CL_INVALID_D3D9_DEVICE_NV -1010 +CONSTANT: CL_INVALID_D3D9_RESOURCE_NV -1011 +CONSTANT: CL_D3D9_RESOURCE_ALREADY_ACQUIRED_NV -1012 +CONSTANT: CL_D3D9_RESOURCE_NOT_ACQUIRED_NV -1013 + +TYPEDEF: void* cl_d3d9_device_source_nv +TYPEDEF: void* cl_d3d9_device_set_nv + +FUNCTION: cl_int clGetDeviceIDsFromD3D9NV ( cl_platform_id platform, cl_d3d9_device_source_nv d3d_device_source, void* d3d_object, cl_d3d9_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ; +FUNCTION: cl_mem clCreateFromD3D9VertexBufferNV ( cl_context context, cl_mem_flags flags, void* id3dvb9_resource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D9IndexBufferNV ( cl_context context, cl_mem_flags flags, void* id3dib9_resource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D9SurfaceNV ( cl_context context, cl_mem_flags flags, void* id3dsurface9_resource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D9TextureNV ( cl_context context, cl_mem_flags flags, void* id3dtexture9_resource, uint miplevel, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D9CubeTextureNV ( cl_context context, cl_mem_flags flags, void* id3dct9_resource, int facetype, uint miplevel, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D9VolumeTextureNV ( cl_context context, cl_mem_flags flags, void* id3dvt9-resource, uint miplevel, cl_int* errcode_ret ) ; +FUNCTION: cl_int clEnqueueAcquireD3D9ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueReleaseD3D9ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; + +! cl_nv_d3d10_sharing.txt +CONSTANT: CL_D3D10_DEVICE_NV HEX: 4010 +CONSTANT: CL_D3D10_DXGI_ADAPTER_NV HEX: 4011 +CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D10_NV HEX: 4012 +CONSTANT: CL_ALL_DEVICES_FOR_D3D10_NV HEX: 4013 +CONSTANT: CL_CONTEXT_D3D10_DEVICE_NV HEX: 4014 +CONSTANT: CL_MEM_D3D10_RESOURCE_NV HEX: 4015 +CONSTANT: CL_IMAGE_D3D10_SUBRESOURCE_NV HEX: 4016 +CONSTANT: CL_COMMAND_ACQUIRE_D3D10_OBJECTS_NV HEX: 4017 +CONSTANT: CL_COMMAND_RELEASE_D3D10_OBJECTS_NV HEX: 4018 +CONSTANT: CL_INVALID_D3D10_DEVICE_NV -1002 +CONSTANT: CL_INVALID_D3D10_RESOURCE_NV -1003 +CONSTANT: CL_D3D10_RESOURCE_ALREADY_ACQUIRED_NV -1004 +CONSTANT: CL_D3D10_RESOURCE_NOT_ACQUIRED_NV -1005 + +TYPEDEF: void* cl_d3d10_device_source_nv +TYPEDEF: void* cl_d3d10_device_set_nv + +FUNCTION: cl_int clGetDeviceIDsFromD3D10NV ( cl_platform_id platform, cl_d3d10_device_source_nv d3d_device_source, void* d3d_object, cl_d3d10_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ; +FUNCTION: cl_mem clCreateFromD3D10BufferNV ( cl_context context, cl_mem_flags flags, void* id3d10buffer_resource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D10Texture2DNV ( cl_context context, cl_mem_flags flags, void* id3d10texture2d_resource, uint subresource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D10Texture3DNV ( cl_context context, cl_mem_flags flags, void* id3d10texture3d_resource, uint subresource, cl_int* errcode_ret ) ; +FUNCTION: cl_int clEnqueueAcquireD3D10ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueReleaseD3D10ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; + +! cl_nv_d3d11_sharing.txt +CONSTANT: CL_D3D11_DEVICE_NV HEX: 4019 +CONSTANT: CL_D3D11_DXGI_ADAPTER_NV HEX: 401A +CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D11_NV HEX: 401B +CONSTANT: CL_ALL_DEVICES_FOR_D3D11_NV HEX: 401C +CONSTANT: CL_CONTEXT_D3D11_DEVICE_NV HEX: 401D +CONSTANT: CL_MEM_D3D11_RESOURCE_NV HEX: 401E +CONSTANT: CL_IMAGE_D3D11_SUBRESOURCE_NV HEX: 401F +CONSTANT: CL_COMMAND_ACQUIRE_D3D11_OBJECTS_NV HEX: 4020 +CONSTANT: CL_COMMAND_RELEASE_D3D11_OBJECTS_NV HEX: 4021 +CONSTANT: CL_INVALID_D3D11_DEVICE_NV -1006 +CONSTANT: CL_INVALID_D3D11_RESOURCE_NV -1007 +CONSTANT: CL_D3D11_RESOURCE_ALREADY_ACQUIRED_NV -1008 +CONSTANT: CL_D3D11_RESOURCE_NOT_ACQUIRED_NV -1009 + +TYPEDEF: void* cl_d3d11_device_source_nv +TYPEDEF: void* cl_d3d11_device_set_nv + +FUNCTION: cl_int clGetDeviceIDsFromD3D11NV ( cl_platform_id platform, cl_d3d11_device_source_nv d3d_device_source, void* d3d_object, cl_d3d11_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ; +FUNCTION: cl_mem clCreateFromD3D11BufferNV ( cl_context context, cl_mem_flags flags, void* id3d11buffer_resource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D11Texture2DNV ( cl_context context, cl_mem_flags flags, void* id3d11texture2d_resource, uint subresource, cl_int* errcode_ret ) ; +FUNCTION: cl_mem clCreateFromD3D11Texture3DNV ( cl_context context, cl_mem_flags flags, void* id3dtexture3d_resource, uint subresource, cl_int* errcode_ret ) ; +FUNCTION: cl_int clEnqueueAcquireD3D11ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; +FUNCTION: cl_int clEnqueueReleaseD3D11ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ; + +! Utility words needed for working with the API +: *size_t ( c-ptr -- value ) + size_t heap-size { + { 4 [ 0 alien-unsigned-4 ] } + { 8 [ 0 alien-unsigned-8 ] } + } case ; inline + +: ( value -- c-ptr ) + size_t heap-size [ (byte-array) ] keep { + { 4 [ [ 0 set-alien-unsigned-4 ] keep ] } + { 8 [ [ 0 set-alien-unsigned-8 ] keep ] } + } case ; inline diff --git a/extra/opencl/ffi/summary.txt b/extra/opencl/ffi/summary.txt new file mode 100644 index 0000000000..e699c14cda --- /dev/null +++ b/extra/opencl/ffi/summary.txt @@ -0,0 +1 @@ +Bindings to OpenCL diff --git a/extra/opencl/ffi/tags.txt b/extra/opencl/ffi/tags.txt new file mode 100644 index 0000000000..bb863cf9a0 --- /dev/null +++ b/extra/opencl/ffi/tags.txt @@ -0,0 +1 @@ +bindings diff --git a/extra/opencl/opencl-docs.factor b/extra/opencl/opencl-docs.factor new file mode 100644 index 0000000000..dc881e47c7 --- /dev/null +++ b/extra/opencl/opencl-docs.factor @@ -0,0 +1,246 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations strings opencl.private +math byte-arrays alien ; +IN: opencl + +HELP: cl-addressing-mode +{ $values + { "sampler" cl-sampler } + { "addressing-mode" cl-addressing-mode } +} +{ $description "Returns the addressing mode of the given sampler." } ; + +HELP: cl-barrier +{ $description "Insert a synchronization barrier into the current command queue." } ; + +HELP: cl-barrier-events +{ $values + { "event/events" "a single event or sequence of events" } +} +{ $description "Insert a synchronization barrier for the specified events into the current command queue." } ; + +HELP: cl-buffer +{ $var-description "Tuple wrapper which will release the memory object handle when disposed." } ; + +HELP: cl-buffer-ptr +{ $var-description "A buffer and offset pair for specifying a starting point for a copy." } ; + +HELP: cl-buffer-range +{ $var-description "A buffer, offset and size triplet for specifying copy ranges." } ; + +HELP: cl-context +{ $var-description "Tuple wrapper which will release the context handle when disposed." } ; + +HELP: cl-current-context +{ $var-description "Symbol for the current cl-context tuple." } ; + +HELP: cl-current-device +{ $var-description "Symbol for the current cl-device tuple." } ; + +HELP: cl-current-queue +{ $var-description "Symbol for the current cl-queue tuple." } ; + +HELP: cl-device +{ $var-description "Tuple wrapper which will release the device handle when disposed." } ; + +HELP: cl-event +{ $var-description "Tuple wrapper which will release the event handle when disposed." } ; + +HELP: cl-event-status +{ $values + { "event" cl-event } + { "execution-status" cl-execution-status } +} +{ $description "Returns the current execution status of the operation represented by the event." } ; + +HELP: cl-event-type +{ $values + { "event" cl-event } + { "command-type" cl-execution-status } +} +{ $description "Returns the type of operation that created the event." } ; + +HELP: cl-filter-mode +{ $values + { "sampler" cl-sampler } + { "filter-mode" cl-filter-mode } +} +{ $description "Returns the filter mode of the sampler object." } ; + +HELP: cl-finish +{ $description "Flush the current command queue and wait till all operations are completed." } ; + +HELP: cl-flush +{ $description "Flush the current command queue to kick off pending operations." } ; + +HELP: cl-kernel +{ $var-description "Tuple wrapper which will release the kernel handle when disposed." } ; + +HELP: cl-kernel-arity +{ $values + { "kernel" cl-kernel } + { "arity" integer } +} +{ $description "Returns the number of inputs that this kernel function accepts." } ; + +HELP: cl-kernel-local-size +{ $values + { "kernel" cl-kernel } + { "size" integer } +} +{ $description "Returns the maximum size of a local work group for this kernel." } ; + +HELP: cl-kernel-name +{ $values + { "kernel" cl-kernel } + { "string" string } +} +{ $description "Returns the name of the kernel function." } ; + +HELP: cl-marker +{ $values + + { "event" cl-event } +} +{ $description "Inserts a marker into the current command queue." } ; + +HELP: cl-normalized-coords? +{ $values + { "sampler" cl-sampler } + { "?" boolean } +} +{ $description "Returns whether the sampler uses normalized coords or not." } ; + +HELP: cl-out-of-order-execution? +{ $values + { "command-queue" cl-queue } + { "?" boolean } +} +{ $description "Returns whether the given command queue allows out of order execution or not." } ; + +HELP: cl-platform +{ $var-description "Tuple summarizing the capabilities and devices of an OpenCL platform." } ; + +HELP: cl-platforms +{ $values + + { "platforms" "sequence of cl-platform"} +} +{ $description "Returns the platforms available for OpenCL computation on this hardware." } ; + +HELP: cl-profile-counters +{ $values + { "event" cl-event } + { "queued" integer } { "submitted" integer } { "started" integer } { "finished" integer } +} +{ $description "Returns the profiling counters for the operation represented by event." } ; + +HELP: cl-profiling? +{ $values + { "command-queue" cl-queue } + { "?" boolean } +} +{ $description "Returns true if the command queue allows profiling." } ; + +HELP: cl-program +{ $var-description "Tuple wrapper which will release the program handle when disposed." } ; + +HELP: cl-queue +{ $var-description "Tuple wrapper which will release the command queue handle when disposed." } ; + +HELP: cl-read-buffer +{ $values + { "buffer-range" cl-buffer-range } + { "byte-array" byte-array } +} +{ $description "Synchronously read a byte-array from the specified buffer location." } ; + +HELP: cl-sampler +{ $var-description "Tuple wrapper which will release the sampler handle when disposed." } ; + +HELP: cl-queue-copy-buffer +{ $values + { "src-buffer-ptr" cl-buffer-ptr } { "dst-buffer-ptr" cl-buffer-ptr } { "size" integer } { "dependent-events" "sequence of events" } + { "event" cl-event } +} +{ $description "Queue a copy operation from " { $snippet "src-buffer-ptr" } " to " { $snippet "dst-buffer-ptr" } ". Dependent events can be passed to order the operation relative to other operations." } ; + +HELP: cl-queue-kernel +{ $values + { "kernel" cl-kernel } { "args" "sequence of cl-buffer or byte-array" } { "sizes" "sequence of integers" } { "dependent-events" "sequence of events" } + { "event" cl-event } +} +{ $description "Queue a kernel for execution with the given arguments. The " { $snippet "sizes" } " argument specifies input array sizes for each dimension. Dependent events can be passed to order the operation relative to other operations." } ; + +HELP: cl-queue-read-buffer +{ $values + { "buffer-range" cl-buffer-range } { "alien" alien } { "dependent-events" "a sequence of events" } + { "event" cl-event } +} +{ $description "Queue a read operation from " { $snippet "buffer-range" } " to " { $snippet "alien" } ". Dependent events can be passed to order the operation relative to other operations." } ; + +HELP: cl-queue-write-buffer +{ $values + { "buffer-range" cl-buffer-range } { "alien" alien } { "dependent-events" "a sequence of events" } + { "event" cl-event } +} +{ $description "Queue a write operation from " { $snippet "alien" } " to " { $snippet "buffer-range" } ". Dependent events can be passed to order the operation relative to other operations." } ; + +HELP: cl-wait +{ $values + { "event/events" "a single event or sequence of events" } +} +{ $description "Synchronously wait for the events to complete." } ; + +HELP: cl-write-buffer +{ $values + { "buffer-range" cl-buffer-range } { "byte-array" byte-array } +} +{ $description "Synchronously write a byte-array to the specified buffer location." } ; + +HELP: +{ $values + { "options" string } { "strings" "sequence of source code strings" } + { "program" "compiled cl-program" } +} +{ $description "Compile the given source code and return a program object. A " { $link cl-error } " is thrown in the event of a compile error." } ; + +HELP: with-cl-state +{ $values + { "context/f" { $maybe cl-context } } { "device/f" { $maybe cl-device } } { "queue/f" { $maybe cl-queue } } { "quot" quotation } +} +{ $description "Run the specified quotation with the given context, device and command queue. False arguments are not bound." } ; + +ARTICLE: "opencl" "OpenCL" +"The " { $vocab-link "opencl" } " vocabulary provides high-level words for using OpenCL." +{ $subsections + cl-platforms + + with-cl-state +} +"Memory Objects:" +{ $subsections + + cl-queue-copy-buffer + cl-read-buffer + cl-queue-read-buffer + cl-write-buffer + cl-queue-write-buffer +} +"Programs and Kernels:" +{ $subsections + + +} + +"Running and Waiting for Completion:" +{ $subsections + cl-queue-kernel + cl-wait + cl-flush + cl-finish +} +; + +ABOUT: "opencl" diff --git a/extra/opencl/opencl-tests.factor b/extra/opencl/opencl-tests.factor new file mode 100644 index 0000000000..09bafa0264 --- /dev/null +++ b/extra/opencl/opencl-tests.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: multiline locals io.encodings.ascii io.encodings.string sequences +math specialized-arrays alien.c-types math.order alien opencl tools.test +accessors arrays destructors kernel namespaces ; +FROM: alien.c-types => float ; +SPECIALIZED-ARRAY: float +IN: opencl.tests + +STRING: kernel-source +__kernel square( + __global float* input, + __global float* output, + const unsigned int count) +{ + int i = get_global_id(0); + if (i < count) + output[i] = input[i] * input[i]; +} +; + +:: opencl-square ( in -- out ) + [ + in byte-length :> num-bytes + in length :> num-floats + cl-platforms first devices>> first :> device + device 1array &dispose :> context + context device f f &dispose :> queue + + context device queue [ + "" kernel-source 1array &dispose "square" &dispose :> kernel + cl-read-access num-bytes in &dispose :> in-buffer + cl-write-access num-bytes f &dispose :> out-buffer + + kernel in-buffer out-buffer num-floats 3array + { num-floats } [ ] cl-queue-kernel &dispose drop + + cl-finish + out-buffer 0 num-bytes cl-read-buffer num-floats + ] with-cl-state + ] with-destructors ; + +[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ] +[ float-array{ 1.0 2.0 3.0 4.0 10.0 } opencl-square ] unit-test diff --git a/extra/opencl/opencl.factor b/extra/opencl/opencl.factor new file mode 100644 index 0000000000..a32c5de3d1 --- /dev/null +++ b/extra/opencl/opencl.factor @@ -0,0 +1,572 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.accessors alien.c-types arrays +byte-arrays combinators combinators.smart continuations destructors +fry io.encodings.ascii io.encodings.string kernel libc locals macros +math math.order multiline opencl.ffi prettyprint sequences +specialized-arrays typed variants namespaces ; +IN: opencl +SPECIALIZED-ARRAYS: void* char size_t ; + + _ '[ _ call cl-success ] keep + *size_t dup _ '[ f _ call cl-success ] keep + _ call ] ; + +MACRO: 2info ( info-quot lift-quot -- quot ) + [ dup ] dip '[ 3dup 0 f 0 _ '[ _ call cl-success ] keep + *size_t dup _ '[ f _ call cl-success ] keep + _ call ] ; + +: info-bool ( handle name quot -- ? ) + [ *uint CL_TRUE = ] info ; inline + +: info-ulong ( handle name quot -- ulong ) + [ *ulonglong ] info ; inline + +: info-int ( handle name quot -- int ) + [ *int ] info ; inline + +: info-uint ( handle name quot -- uint ) + [ *uint ] info ; inline + +: info-size_t ( handle name quot -- size_t ) + [ *size_t ] info ; inline + +: 2info-size_t ( handle1 handle2 name quot -- size_t ) + [ *size_t ] 2info ; inline + +: info-string ( handle name quot -- string ) + [ ascii decode 1 head* ] info ; inline + +: 2info-string ( handle name quot -- string ) + [ ascii decode 1 head* ] 2info ; inline + +: info-size_t-array ( handle name quot -- size_t-array ) + [ [ length size_t heap-size / ] keep swap ] info ; inline + +TUPLE: cl-handle < disposable handle ; +PRIVATE> + +VARIANT: cl-fp-feature + cl-denorm cl-inf-and-nan cl-round-to-nearest cl-round-to-zero cl-round-to-inf cl-fma ; + +VARIANT: cl-cache-type + cl-no-cache cl-read-only-cache cl-read-write-cache ; + +VARIANT: cl-buffer-access-mode + cl-read-access cl-write-access cl-read-write-access ; + +VARIANT: cl-image-channel-order + cl-channel-order-r cl-channel-order-a cl-channel-order-rg cl-channel-order-ra + cl-channel-order-rga cl-channel-order-rgba cl-channel-order-bgra cl-channel-order-argb + cl-channel-order-intensity cl-channel-order-luminance ; + +VARIANT: cl-image-channel-type + cl-channel-type-snorm-int8 cl-channel-type-snorm-int16 cl-channel-type-unorm-int8 + cl-channel-type-unorm-int16 cl-channel-type-unorm-short-565 + cl-channel-type-unorm-short-555 cl-channel-type-unorm-int-101010 + cl-channel-type-signed-int8 cl-channel-type-signed-int16 cl-channel-type-signed-int32 + cl-channel-type-unsigned-int8 cl-channel-type-unsigned-int16 + cl-channel-type-unsigned-int32 cl-channel-type-half-float cl-channel-type-float ; + +VARIANT: cl-addressing-mode + cl-repeat-addressing cl-clamp-to-edge-addressing cl-clamp-addressing cl-no-addressing ; + +VARIANT: cl-filter-mode + cl-filter-nearest cl-filter-linear ; + +VARIANT: cl-command-type + cl-ndrange-kernel-command cl-task-command cl-native-kernel-command cl-read-buffer-command + cl-write-buffer-command cl-copy-buffer-command cl-read-image-command cl-write-image-command + cl-copy-image-command cl-copy-buffer-to-image-command cl-copy-image-to-buffer-command + cl-map-buffer-command cl-map-image-command cl-unmap-mem-object-command + cl-marker-command cl-acquire-gl-objects-command cl-release-gl-objects-command ; + +VARIANT: cl-execution-status + cl-queued cl-submitted cl-running cl-complete cl-failure ; + +TUPLE: cl-platform + id profile version name vendor extensions devices ; + +TUPLE: cl-device + id type vendor-id max-compute-units max-work-item-dimensions + max-work-item-sizes max-work-group-size preferred-vector-width-char + preferred-vector-width-short preferred-vector-width-int + preferred-vector-width-long preferred-vector-width-float + preferred-vector-width-double max-clock-frequency address-bits + max-mem-alloc-size image-support max-read-image-args max-write-image-args + image2d-max-width image2d-max-height image3d-max-width image3d-max-height + image3d-max-depth max-samplers max-parameter-size mem-base-addr-align + min-data-type-align-size single-fp-config global-mem-cache-type + global-mem-cacheline-size global-mem-cache-size global-mem-size + max-constant-buffer-size max-constant-args local-mem? local-mem-size + error-correction-support profiling-timer-resolution endian-little + available compiler-available execute-kernels? execute-native-kernels? + out-of-order-exec-available? profiling-available? + name vendor driver-version profile version extensions ; + +TUPLE: cl-context < cl-handle ; +TUPLE: cl-queue < cl-handle ; +TUPLE: cl-buffer < cl-handle ; +TUPLE: cl-sampler < cl-handle ; +TUPLE: cl-program < cl-handle ; +TUPLE: cl-kernel < cl-handle ; +TUPLE: cl-event < cl-handle ; + +M: cl-context dispose* handle>> clReleaseContext cl-success ; +M: cl-queue dispose* handle>> clReleaseCommandQueue cl-success ; +M: cl-buffer dispose* handle>> clReleaseMemObject cl-success ; +M: cl-sampler dispose* handle>> clReleaseSampler cl-success ; +M: cl-program dispose* handle>> clReleaseProgram cl-success ; +M: cl-kernel dispose* handle>> clReleaseKernel cl-success ; +M: cl-event dispose* handle>> clReleaseEvent cl-success ; + +TUPLE: cl-buffer-ptr + { buffer cl-buffer read-only } + { offset integer read-only } ; +C: cl-buffer-ptr + +TUPLE: cl-buffer-range + { buffer cl-buffer read-only } + { offset integer read-only } + { size integer read-only } ; +C: cl-buffer-range + +SYMBOLS: cl-current-context cl-current-queue cl-current-device ; + +addressing-mode ( cl_addressing_mode -- addressing-mode ) + { + { CL_ADDRESS_REPEAT [ cl-repeat-addressing ] } + { CL_ADDRESS_CLAMP_TO_EDGE [ cl-clamp-to-edge-addressing ] } + { CL_ADDRESS_CLAMP [ cl-clamp-addressing ] } + { CL_ADDRESS_NONE [ cl-no-addressing ] } + } case ; + +: cl_filter_mode>filter-mode ( cl_filter_mode -- filter-mode ) + { + { CL_FILTER_LINEAR [ cl-filter-linear ] } + { CL_FILTER_NEAREST [ cl-filter-nearest ] } + } case ; + +: platform-info-string ( handle name -- string ) + [ clGetPlatformInfo ] info-string ; + +: platform-info ( id -- profile version name vendor extensions ) + { + [ CL_PLATFORM_PROFILE platform-info-string ] + [ CL_PLATFORM_VERSION platform-info-string ] + [ CL_PLATFORM_NAME platform-info-string ] + [ CL_PLATFORM_VENDOR platform-info-string ] + [ CL_PLATFORM_EXTENSIONS platform-info-string ] + } cleave ; + +: cl_device_fp_config>flags ( ulong -- sequence ) + [ { + [ CL_FP_DENORM bitand 0 = [ f ] [ cl-denorm ] if ] + [ CL_FP_INF_NAN bitand 0 = [ f ] [ cl-inf-and-nan ] if ] + [ CL_FP_ROUND_TO_NEAREST bitand 0 = [ f ] [ cl-round-to-nearest ] if ] + [ CL_FP_ROUND_TO_ZERO bitand 0 = [ f ] [ cl-round-to-zero ] if ] + [ CL_FP_ROUND_TO_INF bitand 0 = [ f ] [ cl-round-to-inf ] if ] + [ CL_FP_FMA bitand 0 = [ f ] [ cl-fma ] if ] + } cleave ] { } output>sequence sift ; + +: cl_device_mem_cache_type>cache-type ( uint -- cache-type ) + { + { CL_NONE [ cl-no-cache ] } + { CL_READ_ONLY_CACHE [ cl-read-only-cache ] } + { CL_READ_WRITE_CACHE [ cl-read-write-cache ] } + } case ; + +: device-info-bool ( handle name -- ? ) + [ clGetDeviceInfo ] info-bool ; + +: device-info-ulong ( handle name -- ulong ) + [ clGetDeviceInfo ] info-ulong ; + +: device-info-uint ( handle name -- uint ) + [ clGetDeviceInfo ] info-uint ; + +: device-info-string ( handle name -- string ) + [ clGetDeviceInfo ] info-string ; + +: device-info-size_t ( handle name -- size_t ) + [ clGetDeviceInfo ] info-size_t ; + +: device-info-size_t-array ( handle name -- size_t-array ) + [ clGetDeviceInfo ] info-size_t-array ; + +: device-info ( device-id -- device ) + dup { + [ CL_DEVICE_TYPE device-info-size_t ] + [ CL_DEVICE_VENDOR_ID device-info-uint ] + [ CL_DEVICE_MAX_COMPUTE_UNITS device-info-uint ] + [ CL_DEVICE_MAX_WORK_ITEM_DIMENSIONS device-info-uint ] + [ CL_DEVICE_MAX_WORK_ITEM_SIZES device-info-size_t-array ] + [ CL_DEVICE_MAX_WORK_GROUP_SIZE device-info-size_t ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_CHAR device-info-uint ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_SHORT device-info-uint ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_INT device-info-uint ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_LONG device-info-uint ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT device-info-uint ] + [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE device-info-uint ] + [ CL_DEVICE_MAX_CLOCK_FREQUENCY device-info-uint ] + [ CL_DEVICE_ADDRESS_BITS device-info-uint ] + [ CL_DEVICE_MAX_MEM_ALLOC_SIZE device-info-ulong ] + [ CL_DEVICE_IMAGE_SUPPORT device-info-bool ] + [ CL_DEVICE_MAX_READ_IMAGE_ARGS device-info-uint ] + [ CL_DEVICE_MAX_WRITE_IMAGE_ARGS device-info-uint ] + [ CL_DEVICE_IMAGE2D_MAX_WIDTH device-info-size_t ] + [ CL_DEVICE_IMAGE2D_MAX_HEIGHT device-info-size_t ] + [ CL_DEVICE_IMAGE3D_MAX_WIDTH device-info-size_t ] + [ CL_DEVICE_IMAGE3D_MAX_HEIGHT device-info-size_t ] + [ CL_DEVICE_IMAGE3D_MAX_DEPTH device-info-size_t ] + [ CL_DEVICE_MAX_SAMPLERS device-info-uint ] + [ CL_DEVICE_MAX_PARAMETER_SIZE device-info-size_t ] + [ CL_DEVICE_MEM_BASE_ADDR_ALIGN device-info-uint ] + [ CL_DEVICE_MIN_DATA_TYPE_ALIGN_SIZE device-info-uint ] + [ CL_DEVICE_SINGLE_FP_CONFIG device-info-ulong cl_device_fp_config>flags ] + [ CL_DEVICE_GLOBAL_MEM_CACHE_TYPE device-info-uint cl_device_mem_cache_type>cache-type ] + [ CL_DEVICE_GLOBAL_MEM_CACHELINE_SIZE device-info-uint ] + [ CL_DEVICE_GLOBAL_MEM_CACHE_SIZE device-info-ulong ] + [ CL_DEVICE_GLOBAL_MEM_SIZE device-info-ulong ] + [ CL_DEVICE_MAX_CONSTANT_BUFFER_SIZE device-info-ulong ] + [ CL_DEVICE_MAX_CONSTANT_ARGS device-info-uint ] + [ CL_DEVICE_LOCAL_MEM_TYPE device-info-uint CL_LOCAL = ] + [ CL_DEVICE_LOCAL_MEM_SIZE device-info-ulong ] + [ CL_DEVICE_ERROR_CORRECTION_SUPPORT device-info-bool ] + [ CL_DEVICE_PROFILING_TIMER_RESOLUTION device-info-size_t ] + [ CL_DEVICE_ENDIAN_LITTLE device-info-bool ] + [ CL_DEVICE_AVAILABLE device-info-bool ] + [ CL_DEVICE_COMPILER_AVAILABLE device-info-bool ] + [ CL_DEVICE_EXECUTION_CAPABILITIES device-info-ulong CL_EXEC_KERNEL bitand 0 = not ] + [ CL_DEVICE_EXECUTION_CAPABILITIES device-info-ulong CL_EXEC_NATIVE_KERNEL bitand 0 = not ] + [ CL_DEVICE_QUEUE_PROPERTIES device-info-ulong CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ] + [ CL_DEVICE_QUEUE_PROPERTIES device-info-ulong CL_QUEUE_PROFILING_ENABLE bitand 0 = not ] + [ CL_DEVICE_NAME device-info-string ] + [ CL_DEVICE_VENDOR device-info-string ] + [ CL_DRIVER_VERSION device-info-string ] + [ CL_DEVICE_PROFILE device-info-string ] + [ CL_DEVICE_VERSION device-info-string ] + [ CL_DEVICE_EXTENSIONS device-info-string ] + } cleave cl-device boa ; + +: platform-devices ( platform-id -- devices ) + CL_DEVICE_TYPE_ALL [ + 0 f 0 [ clGetDeviceIDs cl-success ] keep *uint + ] [ + rot dup [ f clGetDeviceIDs cl-success ] keep + ] 2bi ; + +: command-queue-info-ulong ( handle name -- ulong ) + [ clGetCommandQueueInfo ] info-ulong ; + +: sampler-info-bool ( handle name -- ? ) + [ clGetSamplerInfo ] info-bool ; + +: sampler-info-uint ( handle name -- uint ) + [ clGetSamplerInfo ] info-uint ; + +: program-build-info-string ( program-handle device-handle name -- string ) + [ clGetProgramBuildInfo ] 2info-string ; + +: program-build-log ( program-handle device-handle -- string ) + CL_PROGRAM_BUILD_LOG program-build-info-string ; + +: strings>char*-array ( strings -- char*-array ) + [ ascii encode dup length dup malloc [ cl-not-null ] + keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; + +: (program) ( cl-context sources -- program-handle ) + [ handle>> ] dip [ + [ length ] + [ strings>char*-array ] + [ [ length ] size_t-array{ } map-as ] tri + 0 [ clCreateProgramWithSource ] keep *int cl-success + ] with-destructors ; + +:: (build-program) ( program-handle device options -- program ) + program-handle 1 device 1array [ id>> ] void*-array{ } map-as + options ascii encode 0 suffix f f clBuildProgram :> rc + rc { + { CL_BUILD_PROGRAM_FAILURE [ + program-handle device id>> program-build-log program-handle + clReleaseProgram cl-success cl-error f ] } + { CL_SUCCESS [ cl-program new-disposable program-handle >>handle ] } + [ program-handle clReleaseProgram cl-success cl-success f ] + } case ; + +: kernel-info-string ( handle name -- string ) + [ clGetKernelInfo ] info-string ; + +: kernel-info-uint ( handle name -- uint ) + [ clGetKernelInfo ] info-uint ; + +: kernel-work-group-info-size_t ( handle1 handle2 name -- size_t ) + [ clGetKernelWorkGroupInfo ] 2info-size_t ; + +: event-info-uint ( handle name -- uint ) + [ clGetEventInfo ] info-uint ; + +: event-info-int ( handle name -- int ) + [ clGetEventInfo ] info-int ; + +: cl_command_type>command-type ( cl_command-type -- command-type ) + { + { CL_COMMAND_NDRANGE_KERNEL [ cl-ndrange-kernel-command ] } + { CL_COMMAND_TASK [ cl-task-command ] } + { CL_COMMAND_NATIVE_KERNEL [ cl-native-kernel-command ] } + { CL_COMMAND_READ_BUFFER [ cl-read-buffer-command ] } + { CL_COMMAND_WRITE_BUFFER [ cl-write-buffer-command ] } + { CL_COMMAND_COPY_BUFFER [ cl-copy-buffer-command ] } + { CL_COMMAND_READ_IMAGE [ cl-read-image-command ] } + { CL_COMMAND_WRITE_IMAGE [ cl-write-image-command ] } + { CL_COMMAND_COPY_IMAGE [ cl-copy-image-command ] } + { CL_COMMAND_COPY_BUFFER_TO_IMAGE [ cl-copy-buffer-to-image-command ] } + { CL_COMMAND_COPY_IMAGE_TO_BUFFER [ cl-copy-image-to-buffer-command ] } + { CL_COMMAND_MAP_BUFFER [ cl-map-buffer-command ] } + { CL_COMMAND_MAP_IMAGE [ cl-map-image-command ] } + { CL_COMMAND_UNMAP_MEM_OBJECT [ cl-unmap-mem-object-command ] } + { CL_COMMAND_MARKER [ cl-marker-command ] } + { CL_COMMAND_ACQUIRE_GL_OBJECTS [ cl-acquire-gl-objects-command ] } + { CL_COMMAND_RELEASE_GL_OBJECTS [ cl-release-gl-objects-command ] } + } case ; + +: cl_int>execution-status ( clint -- execution-status ) + { + { CL_QUEUED [ cl-queued ] } + { CL_SUBMITTED [ cl-submitted ] } + { CL_RUNNING [ cl-running ] } + { CL_COMPLETE [ cl-complete ] } + [ drop cl-failure ] + } case ; + +: profiling-info-ulong ( handle name -- ulong ) + [ clGetEventProfilingInfo ] info-ulong ; + + +: bind-kernel-arg-buffer ( kernel index buffer -- ) + [ handle>> ] [ cl_mem heap-size ] [ handle>> ] tri* + clSetKernelArg cl-success ; + +: bind-kernel-arg-data ( kernel index byte-array -- ) + [ handle>> ] 2dip + [ byte-length ] keep clSetKernelArg cl-success ; + +GENERIC: bind-kernel-arg ( kernel index data -- ) +M: cl-buffer bind-kernel-arg bind-kernel-arg-buffer ; +M: byte-array bind-kernel-arg bind-kernel-arg-data ; +PRIVATE> + +: with-cl-state ( context/f device/f queue/f quot -- ) + [ + [ + [ cl-current-queue set ] when* + [ cl-current-device set ] when* + [ cl-current-context set ] when* + ] 3curry H{ } make-assoc + ] dip bind ; inline + +: cl-platforms ( -- platforms ) + 0 f 0 [ clGetPlatformIDs cl-success ] keep *uint + dup [ f clGetPlatformIDs cl-success ] keep + [ + dup + [ platform-info ] + [ platform-devices [ device-info ] { } map-as ] bi + cl-platform boa + ] { } map-as ; + +: ( devices -- cl-context ) + [ f ] dip + [ length ] [ [ id>> ] void*-array{ } map-as ] bi + f f 0 [ clCreateContext ] keep *int cl-success + cl-context new-disposable swap >>handle ; + +: ( context device out-of-order? profiling? -- command-queue ) + [ [ handle>> ] [ id>> ] bi* ] 2dip + [ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ] + [ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor + 0 [ clCreateCommandQueue ] keep *int cl-success + cl-queue new-disposable swap >>handle ; + +: cl-out-of-order-execution? ( command-queue -- ? ) + CL_QUEUE_PROPERTIES command-queue-info-ulong + CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ; + +: cl-profiling? ( command-queue -- ? ) + CL_QUEUE_PROPERTIES command-queue-info-ulong + CL_QUEUE_PROFILING_ENABLE bitand 0 = not ; + +: ( buffer-access-mode size initial-data -- buffer ) + [ (current-cl-context) ] 3dip + swap over [ + [ handle>> ] + [ buffer-access-constant ] + [ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor + ] 2dip + 0 [ clCreateBuffer ] keep *int cl-success + cl-buffer new-disposable swap >>handle ; + +: cl-read-buffer ( buffer-range -- byte-array ) + [ (current-cl-queue) handle>> ] dip + [ buffer>> handle>> CL_TRUE ] + [ offset>> ] + [ size>> dup ] tri + [ 0 f f clEnqueueReadBuffer cl-success ] keep ; inline + +: cl-write-buffer ( buffer-range byte-array -- ) + [ + [ (current-cl-queue) handle>> ] dip + [ buffer>> handle>> CL_TRUE ] + [ offset>> ] + [ size>> ] tri + ] dip 0 f f clEnqueueWriteBuffer cl-success ; inline + +: cl-queue-copy-buffer ( src-buffer-ptr dst-buffer-ptr size dependent-events -- event ) + [ + (current-cl-queue) + [ handle>> ] + [ [ buffer>> handle>> ] [ offset>> ] bi ] + [ [ buffer>> handle>> ] [ offset>> ] bi ] + tri* swapd + ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty + f [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event + new-disposable swap >>handle ; + +: cl-queue-read-buffer ( buffer-range alien dependent-events -- event ) + [ + [ (current-cl-queue) handle>> ] dip + [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri + ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty + f [ clEnqueueReadBuffer cl-success ] keep *void* cl-event + new-disposable swap >>handle ; + +: cl-queue-write-buffer ( buffer-range alien dependent-events -- event ) + [ + [ (current-cl-queue) handle>> ] dip + [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri + ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty + f [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event + new-disposable swap >>handle ; + +: ( normalized-coords? addressing-mode filter-mode -- sampler ) + [ (current-cl-context) ] 3dip + [ [ CL_TRUE ] [ CL_FALSE ] if ] + [ addressing-mode-constant ] + [ filter-mode-constant ] + tri* 0 [ clCreateSampler ] keep *int cl-success + cl-sampler new-disposable swap >>handle ; + +: cl-normalized-coords? ( sampler -- ? ) + handle>> CL_SAMPLER_NORMALIZED_COORDS sampler-info-bool ; + +: cl-addressing-mode ( sampler -- addressing-mode ) + handle>> CL_SAMPLER_ADDRESSING_MODE sampler-info-uint cl_addressing_mode>addressing-mode ; + +: cl-filter-mode ( sampler -- filter-mode ) + handle>> CL_SAMPLER_FILTER_MODE sampler-info-uint cl_filter_mode>filter-mode ; + +: ( options strings -- program ) + [ (current-cl-device) ] 2dip + [ (current-cl-context) ] dip + (program) -rot (build-program) ; + +: ( program kernel-name -- kernel ) + [ handle>> ] [ ascii encode 0 suffix ] bi* + 0 [ clCreateKernel ] keep *int cl-success + cl-kernel new-disposable swap >>handle ; + +: cl-kernel-name ( kernel -- string ) + handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; + +: cl-kernel-arity ( kernel -- arity ) + handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; + +: cl-kernel-local-size ( kernel -- size ) + (current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; + +:: cl-queue-kernel ( kernel args sizes dependent-events -- event ) + args [| arg idx | kernel idx arg bind-kernel-arg ] each-index + (current-cl-queue) handle>> + kernel handle>> + sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi + dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi + f [ clEnqueueNDRangeKernel cl-success ] keep *void* + cl-event new-disposable swap >>handle ; + +: cl-event-type ( event -- command-type ) + handle>> CL_EVENT_COMMAND_TYPE event-info-uint cl_command_type>command-type ; + +: cl-event-status ( event -- execution-status ) + handle>> CL_EVENT_COMMAND_EXECUTION_STATUS event-info-int cl_int>execution-status ; + +: cl-profile-counters ( event -- queued submitted started finished ) + handle>> { + [ CL_PROFILING_COMMAND_QUEUED profiling-info-ulong ] + [ CL_PROFILING_COMMAND_SUBMIT profiling-info-ulong ] + [ CL_PROFILING_COMMAND_START profiling-info-ulong ] + [ CL_PROFILING_COMMAND_END profiling-info-ulong ] + } cleave ; inline + +: cl-barrier-events ( event/events -- ) + [ (current-cl-queue) handle>> ] dip + dup sequence? [ 1array ] unless + [ handle>> ] void*-array{ } map-as [ length ] keep clEnqueueWaitForEvents cl-success ; inline + +: cl-marker ( -- event ) + (current-cl-queue) + f [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable + swap >>handle ; inline + +: cl-barrier ( -- ) + (current-cl-queue) clEnqueueBarrier cl-success ; inline + +: cl-flush ( -- ) + (current-cl-queue) handle>> clFlush cl-success ; inline + +: cl-wait ( event/events -- ) + dup sequence? [ 1array ] unless + [ handle>> ] void*-array{ } map-as [ length ] keep clWaitForEvents cl-success ; inline + +: cl-finish ( -- ) + (current-cl-queue) handle>> clFinish cl-success ; inline diff --git a/extra/opencl/summary.txt b/extra/opencl/summary.txt new file mode 100644 index 0000000000..ccb14a0dee --- /dev/null +++ b/extra/opencl/summary.txt @@ -0,0 +1 @@ +High-level vocabulary for using OpenCL diff --git a/extra/opencl/syntax/authors.txt b/extra/opencl/syntax/authors.txt new file mode 100644 index 0000000000..6f03a12101 --- /dev/null +++ b/extra/opencl/syntax/authors.txt @@ -0,0 +1 @@ +Erik Charlebois diff --git a/extra/opencl/syntax/syntax.factor b/extra/opencl/syntax/syntax.factor new file mode 100644 index 0000000000..e9dbabd7fc --- /dev/null +++ b/extra/opencl/syntax/syntax.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.parser classes.singleton classes.union kernel lexer +sequences ; +IN: opencl.syntax + +SYNTAX: SINGLETONS-UNION: + CREATE-CLASS ";" parse-tokens [ create-class-in [ define-singleton-class ] keep ] map define-union-class ; diff --git a/extra/opencl/tags.txt b/extra/opencl/tags.txt new file mode 100644 index 0000000000..bb863cf9a0 --- /dev/null +++ b/extra/opencl/tags.txt @@ -0,0 +1 @@ +bindings From a0ac5a16c3579282dc0fac0a81cb0fef162a0aa7 Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Wed, 3 Mar 2010 00:03:44 -0800 Subject: [PATCH 03/52] Update tags.txt files for Windows DDK --- basis/windows/ddk/hid/tags.txt | 2 +- basis/windows/ddk/setupapi/tags.txt | 2 +- basis/windows/ddk/winusb/tags.txt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/windows/ddk/hid/tags.txt b/basis/windows/ddk/hid/tags.txt index fdce1614de..024277a9b2 100644 --- a/basis/windows/ddk/hid/tags.txt +++ b/basis/windows/ddk/hid/tags.txt @@ -1 +1 @@ -unportable bindings \ No newline at end of file +bindings diff --git a/basis/windows/ddk/setupapi/tags.txt b/basis/windows/ddk/setupapi/tags.txt index 25fe231655..024277a9b2 100644 --- a/basis/windows/ddk/setupapi/tags.txt +++ b/basis/windows/ddk/setupapi/tags.txt @@ -1 +1 @@ -unportable bindings +bindings diff --git a/basis/windows/ddk/winusb/tags.txt b/basis/windows/ddk/winusb/tags.txt index ee46b6bc1f..bb863cf9a0 100644 --- a/basis/windows/ddk/winusb/tags.txt +++ b/basis/windows/ddk/winusb/tags.txt @@ -1 +1 @@ -unportable bindings +bindings From 950f268bad9d9a0536442ddf52315bf956db9488 Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Wed, 3 Mar 2010 02:06:58 -0800 Subject: [PATCH 04/52] Get OpenCL unit tests passing on Win7/NVidia. --- extra/opencl/ffi/ffi-tests.factor | 14 ++--- extra/opencl/ffi/ffi.factor | 26 ++++----- extra/opencl/opencl-tests.factor | 2 +- extra/opencl/opencl.factor | 95 +++++++++++++++++-------------- 4 files changed, 74 insertions(+), 63 deletions(-) diff --git a/extra/opencl/ffi/ffi-tests.factor b/extra/opencl/ffi/ffi-tests.factor index 44bb49ce4e..1ec96e4c76 100644 --- a/extra/opencl/ffi/ffi-tests.factor +++ b/extra/opencl/ffi/ffi-tests.factor @@ -4,11 +4,11 @@ USING: tools.test opencl.ffi multiline locals kernel io.encodings.ascii io.encodings.string sequences libc alien.c-types destructors math specialized-arrays math.order alien ; FROM: alien.c-types => float ; -SPECIALIZED-ARRAY: float +SPECIALIZED-ARRAYS: float void* ; IN: opencl.ffi.tests STRING: kernel-source -__kernel square( +__kernel void square( __global float* input, __global float* output, const unsigned int count) @@ -28,8 +28,10 @@ ERROR: cl-error err ; str-buffer length malloc &free :> str-alien str-alien str-buffer dup length memcpy str-alien ; -:: opencl-square ( in type -- out ) - f CL_DEVICE_TYPE_CPU 1 f [ f clGetDeviceIDs cl-success ] keep *void* :> device-id +:: opencl-square ( in -- out ) + 0 f 0 [ clGetPlatformIDs cl-success ] keep *uint + dup [ f clGetPlatformIDs cl-success ] keep first + CL_DEVICE_TYPE_DEFAULT 1 f [ f clGetDeviceIDs cl-success ] keep *void* :> device-id f 1 device-id f f 0 [ clCreateContext ] keep *int cl-success :> context context device-id 0 0 [ clCreateCommandQueue ] keep *int cl-success :> queue @@ -69,6 +71,4 @@ ERROR: cl-error err ; context clReleaseContext cl-success ; [ float-array{ 1.0 4.0 9.0 16.0 100.0 } ] -[ float-array{ 1.0 2.0 3.0 4.0 10.0 } CL_DEVICE_TYPE_CPU opencl-square ] unit-test -[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ] -[ float-array{ 1.0 2.0 3.0 4.0 10.0 } CL_DEVICE_TYPE_GPU opencl-square ] unit-test +[ float-array{ 1.0 2.0 3.0 4.0 10.0 } opencl-square ] unit-test diff --git a/extra/opencl/ffi/ffi.factor b/extra/opencl/ffi/ffi.factor index 36f1c13519..b1fff5a008 100644 --- a/extra/opencl/ffi/ffi.factor +++ b/extra/opencl/ffi/ffi.factor @@ -1,28 +1,28 @@ ! Copyright (C) 2010 Erik Charlebois. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.libraries alien.syntax classes.struct -combinators system unix.types alien.accessors byte-arrays kernel ; +combinators system alien.accessors byte-arrays kernel ; IN: opencl.ffi << "opencl" { - { [ os windows? ] [ "OpenCL32.dll" ] } + { [ os windows? ] [ "OpenCL.dll" ] } { [ os macosx? ] [ "/System/Library/Frameworks/OpenCL.framework/OpenCL" ] } { [ os unix? ] [ "libopencl.so" ] } } cond "stdcall" add-library >> LIBRARY: opencl ! cl_platform.h -TYPEDEF: int8_t cl_char -TYPEDEF: uint8_t cl_uchar -TYPEDEF: int16_t cl_short -TYPEDEF: uint16_t cl_ushort -TYPEDEF: int32_t cl_int -TYPEDEF: uint32_t cl_uint -TYPEDEF: int64_t cl_long -TYPEDEF: uint64_t cl_ulong -TYPEDEF: uint16_t cl_half; -TYPEDEF: float cl_float; -TYPEDEF: double cl_double; +TYPEDEF: char cl_char +TYPEDEF: uchar cl_uchar +TYPEDEF: short cl_short +TYPEDEF: ushort cl_ushort +TYPEDEF: int cl_int +TYPEDEF: uint cl_uint +TYPEDEF: longlong cl_long +TYPEDEF: ulonglong cl_ulong +TYPEDEF: ushort cl_half; +TYPEDEF: float cl_float; +TYPEDEF: double cl_double; CONSTANT: CL_CHAR_BIT 8 CONSTANT: CL_SCHAR_MAX 127 diff --git a/extra/opencl/opencl-tests.factor b/extra/opencl/opencl-tests.factor index 09bafa0264..6fd7bb581d 100644 --- a/extra/opencl/opencl-tests.factor +++ b/extra/opencl/opencl-tests.factor @@ -8,7 +8,7 @@ SPECIALIZED-ARRAY: float IN: opencl.tests STRING: kernel-source -__kernel square( +__kernel void square( __global float* input, __global float* output, const unsigned int count) diff --git a/extra/opencl/opencl.factor b/extra/opencl/opencl.factor index a32c5de3d1..ddcf16a3b2 100644 --- a/extra/opencl/opencl.factor +++ b/extra/opencl/opencl.factor @@ -12,10 +12,10 @@ SPECIALIZED-ARRAYS: void* char size_t ; ERROR: cl-error err ; : cl-success ( err -- ) - dup CL_SUCCESS = [ drop ] [ cl-error ] if ; + dup CL_SUCCESS = [ drop ] [ cl-error ] if ; inline : cl-not-null ( err -- ) - dup f = [ cl-error ] [ drop ] if ; + dup f = [ cl-error ] [ drop ] if ; inline MACRO: info ( info-quot lift-quot -- quot ) [ dup ] dip '[ 2dup 0 f 0 _ '[ _ call cl-success ] keep @@ -57,6 +57,17 @@ MACRO: 2info ( info-quot lift-quot -- quot ) TUPLE: cl-handle < disposable handle ; PRIVATE> +VARIANT: cl-device-type + cl-device-default cl-device-cpu cl-device-gpu cl-device-accelerator ; + +: size_t>cl-device-type ( size_t -- cl-device-type ) + { + { CL_DEVICE_TYPE_DEFAULT [ cl-device-default ] } + { CL_DEVICE_TYPE_CPU [ cl-device-cpu ] } + { CL_DEVICE_TYPE_GPU [ cl-device-gpu ] } + { CL_DEVICE_TYPE_ACCELERATOR [ cl-device-accelerator ] } + } case ; inline + VARIANT: cl-fp-feature cl-denorm cl-inf-and-nan cl-round-to-nearest cl-round-to-zero cl-round-to-inf cl-fma ; @@ -180,16 +191,16 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; { CL_ADDRESS_CLAMP_TO_EDGE [ cl-clamp-to-edge-addressing ] } { CL_ADDRESS_CLAMP [ cl-clamp-addressing ] } { CL_ADDRESS_NONE [ cl-no-addressing ] } - } case ; + } case ; inline : cl_filter_mode>filter-mode ( cl_filter_mode -- filter-mode ) { { CL_FILTER_LINEAR [ cl-filter-linear ] } { CL_FILTER_NEAREST [ cl-filter-nearest ] } - } case ; + } case ; inline : platform-info-string ( handle name -- string ) - [ clGetPlatformInfo ] info-string ; + [ clGetPlatformInfo ] info-string ; inline : platform-info ( id -- profile version name vendor extensions ) { @@ -215,29 +226,29 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; { CL_NONE [ cl-no-cache ] } { CL_READ_ONLY_CACHE [ cl-read-only-cache ] } { CL_READ_WRITE_CACHE [ cl-read-write-cache ] } - } case ; + } case ; inline : device-info-bool ( handle name -- ? ) - [ clGetDeviceInfo ] info-bool ; + [ clGetDeviceInfo ] info-bool ; inline : device-info-ulong ( handle name -- ulong ) - [ clGetDeviceInfo ] info-ulong ; + [ clGetDeviceInfo ] info-ulong ; inline : device-info-uint ( handle name -- uint ) - [ clGetDeviceInfo ] info-uint ; + [ clGetDeviceInfo ] info-uint ; inline : device-info-string ( handle name -- string ) - [ clGetDeviceInfo ] info-string ; + [ clGetDeviceInfo ] info-string ; inline : device-info-size_t ( handle name -- size_t ) - [ clGetDeviceInfo ] info-size_t ; + [ clGetDeviceInfo ] info-size_t ; inline : device-info-size_t-array ( handle name -- size_t-array ) - [ clGetDeviceInfo ] info-size_t-array ; + [ clGetDeviceInfo ] info-size_t-array ; inline : device-info ( device-id -- device ) dup { - [ CL_DEVICE_TYPE device-info-size_t ] + [ CL_DEVICE_TYPE device-info-size_t size_t>cl-device-type ] [ CL_DEVICE_VENDOR_ID device-info-uint ] [ CL_DEVICE_MAX_COMPUTE_UNITS device-info-uint ] [ CL_DEVICE_MAX_WORK_ITEM_DIMENSIONS device-info-uint ] @@ -295,26 +306,26 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; 0 f 0 [ clGetDeviceIDs cl-success ] keep *uint ] [ rot dup [ f clGetDeviceIDs cl-success ] keep - ] 2bi ; + ] 2bi ; inline : command-queue-info-ulong ( handle name -- ulong ) - [ clGetCommandQueueInfo ] info-ulong ; + [ clGetCommandQueueInfo ] info-ulong ; inline : sampler-info-bool ( handle name -- ? ) - [ clGetSamplerInfo ] info-bool ; + [ clGetSamplerInfo ] info-bool ; inline : sampler-info-uint ( handle name -- uint ) - [ clGetSamplerInfo ] info-uint ; + [ clGetSamplerInfo ] info-uint ; inline : program-build-info-string ( program-handle device-handle name -- string ) - [ clGetProgramBuildInfo ] 2info-string ; + [ clGetProgramBuildInfo ] 2info-string ; inline : program-build-log ( program-handle device-handle -- string ) - CL_PROGRAM_BUILD_LOG program-build-info-string ; + CL_PROGRAM_BUILD_LOG program-build-info-string ; inline : strings>char*-array ( strings -- char*-array ) [ ascii encode dup length dup malloc [ cl-not-null ] - keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; + keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; inline : (program) ( cl-context sources -- program-handle ) [ handle>> ] dip [ @@ -326,8 +337,8 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; :: (build-program) ( program-handle device options -- program ) program-handle 1 device 1array [ id>> ] void*-array{ } map-as - options ascii encode 0 suffix f f clBuildProgram :> rc - rc { + options ascii encode 0 suffix f f clBuildProgram + { { CL_BUILD_PROGRAM_FAILURE [ program-handle device id>> program-build-log program-handle clReleaseProgram cl-success cl-error f ] } @@ -336,19 +347,19 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; } case ; : kernel-info-string ( handle name -- string ) - [ clGetKernelInfo ] info-string ; + [ clGetKernelInfo ] info-string ; inline : kernel-info-uint ( handle name -- uint ) - [ clGetKernelInfo ] info-uint ; + [ clGetKernelInfo ] info-uint ; inline : kernel-work-group-info-size_t ( handle1 handle2 name -- size_t ) - [ clGetKernelWorkGroupInfo ] 2info-size_t ; + [ clGetKernelWorkGroupInfo ] 2info-size_t ; inline : event-info-uint ( handle name -- uint ) - [ clGetEventInfo ] info-uint ; + [ clGetEventInfo ] info-uint ; inline : event-info-int ( handle name -- int ) - [ clGetEventInfo ] info-int ; + [ clGetEventInfo ] info-int ; inline : cl_command_type>command-type ( cl_command-type -- command-type ) { @@ -378,19 +389,19 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; { CL_RUNNING [ cl-running ] } { CL_COMPLETE [ cl-complete ] } [ drop cl-failure ] - } case ; + } case ; inline : profiling-info-ulong ( handle name -- ulong ) - [ clGetEventProfilingInfo ] info-ulong ; + [ clGetEventProfilingInfo ] info-ulong ; inline : bind-kernel-arg-buffer ( kernel index buffer -- ) [ handle>> ] [ cl_mem heap-size ] [ handle>> ] tri* - clSetKernelArg cl-success ; + clSetKernelArg cl-success ; inline : bind-kernel-arg-data ( kernel index byte-array -- ) [ handle>> ] 2dip - [ byte-length ] keep clSetKernelArg cl-success ; + [ byte-length ] keep clSetKernelArg cl-success ; inline GENERIC: bind-kernel-arg ( kernel index data -- ) M: cl-buffer bind-kernel-arg bind-kernel-arg-buffer ; @@ -431,11 +442,11 @@ PRIVATE> : cl-out-of-order-execution? ( command-queue -- ? ) CL_QUEUE_PROPERTIES command-queue-info-ulong - CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ; + CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ; inline : cl-profiling? ( command-queue -- ? ) CL_QUEUE_PROPERTIES command-queue-info-ulong - CL_QUEUE_PROFILING_ENABLE bitand 0 = not ; + CL_QUEUE_PROFILING_ENABLE bitand 0 = not ; inline : ( buffer-access-mode size initial-data -- buffer ) [ (current-cl-context) ] 3dip @@ -498,13 +509,13 @@ PRIVATE> cl-sampler new-disposable swap >>handle ; : cl-normalized-coords? ( sampler -- ? ) - handle>> CL_SAMPLER_NORMALIZED_COORDS sampler-info-bool ; + handle>> CL_SAMPLER_NORMALIZED_COORDS sampler-info-bool ; inline : cl-addressing-mode ( sampler -- addressing-mode ) - handle>> CL_SAMPLER_ADDRESSING_MODE sampler-info-uint cl_addressing_mode>addressing-mode ; + handle>> CL_SAMPLER_ADDRESSING_MODE sampler-info-uint cl_addressing_mode>addressing-mode ; inline : cl-filter-mode ( sampler -- filter-mode ) - handle>> CL_SAMPLER_FILTER_MODE sampler-info-uint cl_filter_mode>filter-mode ; + handle>> CL_SAMPLER_FILTER_MODE sampler-info-uint cl_filter_mode>filter-mode ; inline : ( options strings -- program ) [ (current-cl-device) ] 2dip @@ -514,16 +525,16 @@ PRIVATE> : ( program kernel-name -- kernel ) [ handle>> ] [ ascii encode 0 suffix ] bi* 0 [ clCreateKernel ] keep *int cl-success - cl-kernel new-disposable swap >>handle ; + cl-kernel new-disposable swap >>handle ; inline : cl-kernel-name ( kernel -- string ) - handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; + handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; inline : cl-kernel-arity ( kernel -- arity ) - handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; + handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; inline : cl-kernel-local-size ( kernel -- size ) - (current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; + (current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline :: cl-queue-kernel ( kernel args sizes dependent-events -- event ) args [| arg idx | kernel idx arg bind-kernel-arg ] each-index @@ -535,10 +546,10 @@ PRIVATE> cl-event new-disposable swap >>handle ; : cl-event-type ( event -- command-type ) - handle>> CL_EVENT_COMMAND_TYPE event-info-uint cl_command_type>command-type ; + handle>> CL_EVENT_COMMAND_TYPE event-info-uint cl_command_type>command-type ; inline : cl-event-status ( event -- execution-status ) - handle>> CL_EVENT_COMMAND_EXECUTION_STATUS event-info-int cl_int>execution-status ; + handle>> CL_EVENT_COMMAND_EXECUTION_STATUS event-info-int cl_int>execution-status ; inline : cl-profile-counters ( event -- queued submitted started finished ) handle>> { From 15e6a7fa5e4069f0858e7306fcd6f9f16b52e93f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 5 Mar 2010 21:50:40 -0800 Subject: [PATCH 05/52] move error summaries for effect parsing errors to debugger vocab --- basis/debugger/debugger.factor | 4 ++++ basis/stack-checker/errors/prettyprint/prettyprint.factor | 5 ----- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index b6497c52a9..69156208b8 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -328,6 +328,10 @@ M: lexer-error error-help M: bad-effect summary drop "Bad stack effect declaration" ; +M: invalid-effect-variable summary + drop "Stack effect variables can only occur as the first input or output" ; +M: effect-variable-can't-have-type summary + drop "Stack effect variables cannot have a declared type" ; M: bad-escape error. "Bad escape code: \\" write diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 9d36e9c56c..589bd0a056 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -73,8 +73,3 @@ M: invalid-quotation-input error. dup summary print [ quots>> ] [ branches>> ] bi quots-and-branches. ; -M: invalid-effect-variable summary - drop "Stack effect variables can only occur as the first input or output" ; -M: effect-variable-can't-have-type summary - drop "Stack effect variables cannot have a declared type" ; - From 48b433750b08f5b79f64ff9195e389c853fe2e27 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 5 Mar 2010 21:51:13 -0800 Subject: [PATCH 06/52] clean up polymorphic stack effects in fuel --- extra/fuel/fuel.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 9d47bf8cc4..1c0dc9c480 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -55,14 +55,14 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( suggestions quot -- ... ) +: fuel-use-suggested-vocabs ( ..a suggestions quot: ( ..a -- ..b ) -- ..b ) [ :uses-suggestions set ] dip [ try-suggested-restarts rethrow ] recover ; inline : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline -: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... ) +: fuel-with-autouse ( ..a quot: ( ..a -- ..b ) -- ..b ) [ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline : fuel-get-uses ( lines -- ) From 9571bf6d4bb4cec39bb6695967372d001e5a7001 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 5 Mar 2010 21:51:38 -0800 Subject: [PATCH 07/52] give terminating stack effects a pass in the polymorphic checker --- .../row-polymorphism-tests.factor | 5 ++-- .../row-polymorphism/row-polymorphism.factor | 29 ++++++++++--------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor index 6401258100..ec73ec3b21 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor @@ -47,6 +47,8 @@ H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer +H{ { "a" 0 } { "b" 1 } } [ [ 1 + ] [ "oops" throw ] if* ] test-poly-infer + [ [ write write ] each ] poly-infer-must-fail [ [ ] each ] poly-infer-must-fail [ [ dup ] map ] poly-infer-must-fail @@ -63,9 +65,6 @@ H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer [ [ ] [ drop ] if* ] poly-infer-must-fail [ [ ] [ 2dup ] if* ] poly-infer-must-fail -[ "derp" each ] poly-infer-must-fail [ each ] poly-infer-must-fail-unknown -[ "derp" [ "derp" ] if ] poly-infer-must-fail -[ [ "derp" ] "derp" if ] poly-infer-must-fail [ [ "derp" ] if ] poly-infer-must-fail-unknown diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index b1acf50551..85d151d478 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -55,17 +55,19 @@ M: curried >error-quot [ 2drop ] if ; inline :: (check-input) ( declared actual -- ) - actual declared [ in>> length ] bi@ declared in-var>> - [ check-variable ] keep :> ( in-diff in-var ) - actual declared [ out>> length ] bi@ declared out-var>> - [ check-variable ] keep :> ( out-diff out-var ) - { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| - [ - in-var [ in-diff swap adjust-variable ] when* - out-var [ out-diff swap adjust-variable ] when* - ] [ - abandon-check - ] if ; + actual terminated?>> [ + actual declared [ in>> length ] bi@ declared in-var>> + [ check-variable ] keep :> ( in-diff in-var ) + actual declared [ out>> length ] bi@ declared out-var>> + [ check-variable ] keep :> ( out-diff out-var ) + { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| + [ + in-var [ in-diff swap adjust-variable ] when* + out-var [ out-diff swap adjust-variable ] when* + ] [ + abandon-check + ] if + ] unless ; : infer-value ( value -- effect ) dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline @@ -92,9 +94,10 @@ PRIVATE> : check-polymorphic-effect ( word -- ) current-word get [ - dup current-word set stack-effect - dup { [ in-var>> ] [ out-var>> ] } 1|| + dup current-word set + stack-effect dup { [ in-var>> ] [ out-var>> ] } 1|| [ infer-polymorphic-vars ] when drop ] dip current-word set ; SYMBOL: infer-polymorphic? +infer-polymorphic? [ t ] initialize From 3b9d6f64a4271f29b68cfef15f955822ed2a5173 Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Fri, 5 Mar 2010 22:37:10 -0800 Subject: [PATCH 08/52] Get the OpenCL driver name right on Linux, confirm test passes --- extra/opencl/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opencl/ffi/ffi.factor b/extra/opencl/ffi/ffi.factor index b1fff5a008..90f392a22e 100644 --- a/extra/opencl/ffi/ffi.factor +++ b/extra/opencl/ffi/ffi.factor @@ -7,7 +7,7 @@ IN: opencl.ffi << "opencl" { { [ os windows? ] [ "OpenCL.dll" ] } { [ os macosx? ] [ "/System/Library/Frameworks/OpenCL.framework/OpenCL" ] } - { [ os unix? ] [ "libopencl.so" ] } + { [ os unix? ] [ "libOpenCL.so" ] } } cond "stdcall" add-library >> LIBRARY: opencl From 17df15280e6c32fae6184cb5fdd1ce1fdbc8facc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 5 Mar 2010 22:42:05 -0800 Subject: [PATCH 09/52] generalize stack effect of while, until, and produce --- core/kernel/kernel.factor | 4 ++-- core/sequences/sequences.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ae8763e7f8..3a53eb91e2 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -177,10 +177,10 @@ UNION: boolean POSTPONE: t POSTPONE: f ; : do ( pred body -- pred body ) dup 2dip ; inline -: while ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... ) +: while ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b ) swap do compose [ loop ] curry when ; inline -: until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ) +: until ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b ) [ [ not ] compose ] dip while ; inline ! Object protocol diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cb8d2abedf..314447febf 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -513,10 +513,10 @@ PRIVATE> : collector ( quot -- quot' vec ) V{ } collector-for ; inline -: produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) exemplar -- ... seq ) +: produce-as ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) exemplar -- ..b seq ) dup [ collector-for [ while ] dip ] curry dip like ; inline -: produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... seq ) +: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq ) { } produce-as ; inline : follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq ) From eff65915b0cf86f4b5ef39ccbd7b9a0402415e11 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 6 Mar 2010 08:48:39 +0100 Subject: [PATCH 10/52] A* algorithm implementation --- extra/astar/astar-docs.factor | 42 +++++++++++++ extra/astar/astar-tests.factor | 109 +++++++++++++++++++++++++++++++++ extra/astar/astar.factor | 72 ++++++++++++++++++++++ extra/astar/authors.txt | 1 + extra/astar/summary.txt | 1 + 5 files changed, 225 insertions(+) create mode 100644 extra/astar/astar-docs.factor create mode 100644 extra/astar/astar-tests.factor create mode 100644 extra/astar/astar.factor create mode 100644 extra/astar/authors.txt create mode 100644 extra/astar/summary.txt diff --git a/extra/astar/astar-docs.factor b/extra/astar/astar-docs.factor new file mode 100644 index 0000000000..b8da237ed6 --- /dev/null +++ b/extra/astar/astar-docs.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2010 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: astar + +{ find-path considered } related-words + +HELP: +{ $values + { "neighbours" "a quotation with stack effect ( node -- seq )" } + { "cost" "a quotation with stack effect ( from to -- cost )" } + { "heuristic" "a quotation with stack effect ( pos target -- cost )" } + { "astar" "a astar tuple" } +} +{ $description "Build an astar object from the given quotations. The " + { $snippet "neighbours" } " one builds the list of neighbours. The " + { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent " + "respectively the cost for transitioning from a node to one of its neighbour, " + "and the underestimated cost for going from a node to the target." +} ; + +HELP: find-path +{ $values + { "start" "a node" } + { "target" "a node" } + { "astar" "a astar tuple" } + { "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" } + ", or f if no such path exists" } +} +{ $description "Find a path between " { $snippet "start" } " and " { $snippet "target" } + " using the A* algorithm. The " { $snippet "astar" } " tuple must have been previously " + " built using " { $link } "." +} ; + +HELP: considered +{ $values + { "astar" "a astar tuple" } + { "considered" "a sequence" } +} +{ $description "When called after a call to " { $link find-path } ", return a list of nodes " + "which have been examined during the A* exploration." +} ; diff --git a/extra/astar/astar-tests.factor b/extra/astar/astar-tests.factor new file mode 100644 index 0000000000..2567ad046d --- /dev/null +++ b/extra/astar/astar-tests.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2010 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs astar combinators hashtables kernel literals math math.functions +math.vectors sequences sorting splitting strings tools.test ; +IN: astar.tests + +<< + +! Use a 10x9 maze (see below) to try to go from s to e, f or g. +! X means that a position is unreachable. +! The costs model is: +! - going up costs 5 points +! - going down costs 1 point +! - going left or right costs 2 points + +: reachable? ( pos -- ? ) + first2 [ 2 * 5 + ] [ 2 + ] bi* $[ +" 0 1 2 3 4 5 6 7 8 9 + + 0 X X X X X X X X X X + 1 X s f X X + 2 X X X X X X X X X + 3 X X X X X X X X X + 4 X X X X X X + 5 X X X X X + 6 X X X X X X e X + 7 X g X X + 8 X X X X X X X X X X" + "\n" split ] nth nth CHAR: X = not ; + +: neighbours ( pos -- neighbours ) + first2 + { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave + 4array + [ reachable? ] filter ; + +: cost ( from to -- cost ) + 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; + +: heuristic ( pos1 pos2 -- distance ) + v- [ sq ] map sum sqrt ; + +: test1 ( to -- path considered ) + { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] [ find-path ] [ considered ] bi ; +>> + +! Existing path from s to f +[ + { + { 1 1 } + { 2 1 } + { 3 1 } + { 4 1 } + { 4 2 } + { 4 3 } + { 4 4 } + { 4 5 } + { 4 6 } + { 4 7 } + { 5 7 } + { 6 7 } + { 7 7 } + { 8 7 } + { 8 6 } + } +] [ + { 8 6 } test1 drop +] unit-test + +! Check that only the right positions have been considered in the s to f path +[ 7 ] [ { 7 1 } test1 nip length ] unit-test + +! Non-existing path from s to g -- all positions must have been considered +[ f 26 ] [ { 1 7 } test1 length ] unit-test + +<< + +! Look for a path between A and C. The best path is A --> D --> C. C will be placed +! in the open set early because B will be examined first. This checks that the evaluation +! of C is correctly replaced in the open set. +! +! We use no heuristic here and always return 0. +! +! (5) +! B ---> C <-------- +! \ (2) +! ^ ^ | +! | | | +! (1) | | (2) | +! | | | +! +! A ---> D ---------> E ---> F +! (2) (1) (1) + +: n ( pos -- neighbours ) + $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ; + +: c ( from to -- cost ) + "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ; + +: test2 ( fromto -- path considered ) + first2 [ n ] [ c ] [ 2drop 0 ] [ find-path ] [ considered natural-sort >string ] bi ; +>> + +! Check path from A to C -- all nodes but F must have been examined +[ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test + +! No path from D to B -- all nodes reachable from D must have been examined +[ f "CDEF" ] [ "DB" test2 ] unit-test diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor new file mode 100644 index 0000000000..6a5c431ae4 --- /dev/null +++ b/extra/astar/astar.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2010 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs heaps kernel math math.order sequences sets shuffle ; +IN: astar + +! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A* + +> at* [ over open-set>> heap-delete ] [ drop ] if + [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ; + +: add-to-open-set ( node astar -- ) + [ g>> at ] 2keep + [ [ goal>> ] [ heuristic>> call( n1 n2 -- c ) ] bi + ] 2keep + (add-to-open-set) ; + +: ?add-to-open-set ( node astar -- ) + 2dup in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ; + +: move-to-closed-set ( node astar -- ) + [ in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ; + +: get-first ( astar -- node ) + [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ; + +: set-g ( origin g node astar -- ) + [ [ origin>> set-at ] [ g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ; + +: cost-through ( origin node astar -- cost ) + [ cost>> call( n1 n2 -- c ) ] [ nip g>> at ] 3bi + ; + +: ?set-g ( origin node astar -- ) + [ cost-through ] 3keep [ swap ] 2dip + 3dup g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ; + +: build-path ( target astar -- path ) + [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ; + +: handle ( node astar -- ) + dupd [ neighbours>> call( node -- neighbours ) ] keep [ ?set-g ] curry with each ; + +: (find-path) ( astar -- path/f ) + dup open-set>> heap-empty? [ + drop f + ] [ + [ get-first ] keep 2dup goal>> = [ build-path ] [ [ handle ] [ (find-path) ] bi ] if + ] if ; + +: (init) ( from to astar -- ) + swap >>goal + H{ } clone >>g + H{ } clone >>origin + H{ } clone >>in-open-set + H{ } clone >>in-closed-set + >>open-set + [ 0 ] 2dip [ (add-to-open-set) ] [ g>> set-at ] 3bi ; + +PRIVATE> + +: find-path ( start target astar -- path/f ) + [ (init) ] [ (find-path) ] bi ; + +: ( neighbours cost heuristic -- astar ) + astar new swap >>heuristic swap >>cost swap >>neighbours ; + +: considered ( astar -- considered ) + in-closed-set>> keys ; diff --git a/extra/astar/authors.txt b/extra/astar/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/astar/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/astar/summary.txt b/extra/astar/summary.txt new file mode 100644 index 0000000000..ff3167a133 --- /dev/null +++ b/extra/astar/summary.txt @@ -0,0 +1 @@ +A* path-finding algorithm From 542096b5286e7fc40e038086c3933ce49208a3a6 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 6 Mar 2010 14:14:54 +0100 Subject: [PATCH 11/52] Use distance from math.vectors --- extra/astar/astar-tests.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/astar/astar-tests.factor b/extra/astar/astar-tests.factor index 2567ad046d..6dd27cf372 100644 --- a/extra/astar/astar-tests.factor +++ b/extra/astar/astar-tests.factor @@ -37,11 +37,8 @@ IN: astar.tests : cost ( from to -- cost ) 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; -: heuristic ( pos1 pos2 -- distance ) - v- [ sq ] map sum sqrt ; - : test1 ( to -- path considered ) - { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] [ find-path ] [ considered ] bi ; + { 1 1 } swap [ neighbours ] [ cost ] [ distance ] [ find-path ] [ considered ] bi ; >> ! Existing path from s to f From 0e35c883aeb04ceed9c8b1bbde8183b08d6888bd Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 6 Mar 2010 14:31:46 +0100 Subject: [PATCH 12/52] Remove useless USING: --- extra/astar/astar.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor index 6a5c431ae4..1912b6af21 100644 --- a/extra/astar/astar.factor +++ b/extra/astar/astar.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs heaps kernel math math.order sequences sets shuffle ; +USING: accessors assocs heaps kernel math sequences sets shuffle ; IN: astar ! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A* From adcf50514c6334aca97c1830553c427411507256 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 6 Mar 2010 14:37:35 +0100 Subject: [PATCH 13/52] Use a better heuristic --- extra/astar/astar-tests.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/astar/astar-tests.factor b/extra/astar/astar-tests.factor index 6dd27cf372..11b2dfcaa2 100644 --- a/extra/astar/astar-tests.factor +++ b/extra/astar/astar-tests.factor @@ -34,11 +34,14 @@ IN: astar.tests 4array [ reachable? ] filter ; +: heuristic ( from to -- cost ) + v- [ abs ] [ + ] map-reduce ; + : cost ( from to -- cost ) 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ; : test1 ( to -- path considered ) - { 1 1 } swap [ neighbours ] [ cost ] [ distance ] [ find-path ] [ considered ] bi ; + { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] [ find-path ] [ considered ] bi ; >> ! Existing path from s to f From 68dd644233bcc0391cc6dd58cf8e2882478fca89 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 6 Mar 2010 12:28:09 -0800 Subject: [PATCH 14/52] add unit test to show that polymorphic check breaks inference of inline recursive words --- .../row-polymorphism/row-polymorphism-tests.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor index ec73ec3b21..a5572336c0 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor @@ -1,11 +1,13 @@ ! (c)2010 Joe Groff bsd license -USING: effects fry io kernel math namespaces sequences -system tools.test +USING: accessors effects fry io kernel make math namespaces sequences +splitting system tools.test +stack-checker stack-checker.backend stack-checker.errors stack-checker.row-polymorphism stack-checker.state stack-checker.values ; +FROM: splitting.private => split, ; IN: stack-checker.row-polymorphism.tests : infer-polymorphic-quot ( quot -- vars ) @@ -49,6 +51,14 @@ H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer H{ { "a" 0 } { "b" 1 } } [ [ 1 + ] [ "oops" throw ] if* ] test-poly-infer +H{ } [ [ [ member? ] curry split, ] { } make ] test-poly-infer + +[ (( x x -- x )) ] [ + t infer-polymorphic? [ + [ [ [ member? ] curry split, ] { } make ] infer + ] with-variable +] unit-test + [ [ write write ] each ] poly-infer-must-fail [ [ ] each ] poly-infer-must-fail [ [ dup ] map ] poly-infer-must-fail From 211cafed4a592994370daf145de85f552869f249 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 6 Mar 2010 14:01:26 -0800 Subject: [PATCH 15/52] tag opencl.* untested --- extra/opencl/ffi/tags.txt | 1 + extra/opencl/syntax/tags.txt | 1 + extra/opencl/tags.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 extra/opencl/syntax/tags.txt diff --git a/extra/opencl/ffi/tags.txt b/extra/opencl/ffi/tags.txt index bb863cf9a0..a9d28becd8 100644 --- a/extra/opencl/ffi/tags.txt +++ b/extra/opencl/ffi/tags.txt @@ -1 +1,2 @@ bindings +untested diff --git a/extra/opencl/syntax/tags.txt b/extra/opencl/syntax/tags.txt new file mode 100644 index 0000000000..5d77766703 --- /dev/null +++ b/extra/opencl/syntax/tags.txt @@ -0,0 +1 @@ +untested diff --git a/extra/opencl/tags.txt b/extra/opencl/tags.txt index bb863cf9a0..a9d28becd8 100644 --- a/extra/opencl/tags.txt +++ b/extra/opencl/tags.txt @@ -1 +1,2 @@ bindings +untested From 339cc8f04e88b6d5fd47607c2e06ba6727f76319 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 11:44:44 -0800 Subject: [PATCH 16/52] row polymorphism new approach: wrap polymorphic quotation inputs in a "declared-effect" value. M\ declared-effect infer-call* will then assert the effect of declared-effect values during the normal course of stack inference --- basis/stack-checker/branches/branches.factor | 11 +- basis/stack-checker/inlining/inlining.factor | 2 +- .../known-words/known-words.factor | 10 ++ .../row-polymorphism-tests.factor | 80 ------------- .../row-polymorphism/row-polymorphism.factor | 108 ++++-------------- .../stack-checker/stack-checker-tests.factor | 4 +- basis/stack-checker/values/values.factor | 35 +++++- 7 files changed, 77 insertions(+), 173 deletions(-) delete mode 100644 basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 99e5a70409..2862b03f20 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -91,6 +91,9 @@ M: literal infer-branch [ value>> quotation set ] [ infer-literal-quot ] bi ] H{ } make-assoc ; +M: declared-effect infer-branch + value>> infer-branch ; + M: callable infer-branch [ copy-inference @@ -107,12 +110,18 @@ M: callable infer-branch infer-branches [ first2 #if, ] dip compute-phi-function ; +GENERIC: curried/composed? ( known -- ? ) +M: object curried/composed? drop f ; +M: curried curried/composed? drop t ; +M: composed curried/composed? drop t ; +M: declared-effect curried/composed? value>> known curried/composed? ; + : infer-if ( -- ) 2 literals-available? [ (infer-if) ] [ drop 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] any? [ + dup [ known curried/composed? ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] infer-quot-here diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index b1d6b6d9ef..c83f609868 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -142,7 +142,7 @@ SYMBOL: enter-out : inline-word ( word -- ) commit-literals [ depends-on-definition ] - [ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ] + [ declare-input-effects ] [ dup inline-recursive-label [ call-recursive-inline-word diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e93dca9072..03c45b9487 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -98,6 +98,16 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; +: Pdeclared-effect ( x -- x ) + dup + [ word>> P. ] + [ effect>> P. ] + [ value>> known known>callable P. ] tri ; + +M: declared-effect infer-call* + Pdeclared-effect + nip value>> (infer-call) ; + M: input-parameter infer-call* \ call unknown-macro-input ; M: object infer-call* \ call bad-macro-input ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor deleted file mode 100644 index a5572336c0..0000000000 --- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor +++ /dev/null @@ -1,80 +0,0 @@ -! (c)2010 Joe Groff bsd license -USING: accessors effects fry io kernel make math namespaces sequences -splitting system tools.test -stack-checker -stack-checker.backend -stack-checker.errors -stack-checker.row-polymorphism -stack-checker.state -stack-checker.values ; -FROM: splitting.private => split, ; -IN: stack-checker.row-polymorphism.tests - -: infer-polymorphic-quot ( quot -- vars ) - t infer-polymorphic? [ - unclip-last [ - dup current-word set - init-inference - init-known-values - [ [ [ set-known ] [ push-d ] bi ] each ] - [ stack-effect ] bi* - infer-polymorphic-vars - ] with-scope - ] with-variable ; - -: test-poly-infer ( effect quot -- ) - [ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline - -: poly-infer-must-fail ( quot -- ) - '[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline -: poly-infer-must-fail-unknown ( quot -- ) - '[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline - -H{ { "." 0 } } [ [ write ] each ] test-poly-infer -H{ { "." 1 } } [ [ append ] each ] test-poly-infer -H{ { "." 0 } } [ [ ] map ] test-poly-infer -H{ { "." 0 } } [ [ reverse ] map ] test-poly-infer -H{ { "." 1 } } [ [ append dup ] map ] test-poly-infer -H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer - -H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip ] if ] test-poly-infer -H{ { "a" 2 } { "b" 3 } } [ [ dup ] [ over ] if ] test-poly-infer -H{ { "a" 0 } { "b" 1 } } [ [ os ] [ cpu ] if ] test-poly-infer -H{ { "a" 1 } { "b" 2 } } [ [ os ] [ 1 + cpu ] if ] test-poly-infer - -H{ { "a" 0 } { "b" 0 } } [ [ write ] [ "(f)" write ] if* ] test-poly-infer -H{ { "a" 0 } { "b" 1 } } [ [ ] [ f ] if* ] test-poly-infer -H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ drop f ] if* ] test-poly-infer -H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer -H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer -H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer - -H{ { "a" 0 } { "b" 1 } } [ [ 1 + ] [ "oops" throw ] if* ] test-poly-infer - -H{ } [ [ [ member? ] curry split, ] { } make ] test-poly-infer - -[ (( x x -- x )) ] [ - t infer-polymorphic? [ - [ [ [ member? ] curry split, ] { } make ] infer - ] with-variable -] unit-test - -[ [ write write ] each ] poly-infer-must-fail -[ [ ] each ] poly-infer-must-fail -[ [ dup ] map ] poly-infer-must-fail -[ [ drop ] map ] poly-infer-must-fail -[ [ 1 + ] map-index ] poly-infer-must-fail - -[ [ dup ] [ ] if ] poly-infer-must-fail -[ [ 2dup ] [ over ] if ] poly-infer-must-fail -[ [ drop ] [ ] if ] poly-infer-must-fail - -[ [ ] [ ] if* ] poly-infer-must-fail -[ [ dup ] [ ] if* ] poly-infer-must-fail -[ [ drop ] [ drop ] if* ] poly-infer-must-fail -[ [ ] [ drop ] if* ] poly-infer-must-fail -[ [ ] [ 2dup ] if* ] poly-infer-must-fail - -[ each ] poly-infer-must-fail-unknown -[ [ "derp" ] if ] poly-infer-must-fail-unknown - diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 85d151d478..5f798b1760 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -10,94 +10,26 @@ stack-checker.values stack-checker.visitor ; IN: stack-checker.row-polymorphism - d-length + n d-length < [ + d-length 1 - n - :> n' + n' meta-d [| value | + value word effect variables :> known' + :> value' + known' value' set-known + value' + ] change-nth + ] [ word unknown-macro-input ] if ; -SYMBOL: (unknown) +:: declare-input-effects ( word -- ) + H{ } clone :> variables + word stack-effect in>> [| in n | + in ?quotation-effect [| effect | + word effect variables n declare-effect-d + ] when* + ] each-index ; -GENERIC: >error-quot ( known -- quot ) - -M: object >error-quot drop (unknown) ; -M: literal >error-quot value>> ; -M: composed >error-quot - [ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi - \ compose [ ] 3sequence ; -M: curried >error-quot - [ obj>> known >error-quot ] [ quot>> known >error-quot ] bi - \ curry [ ] 3sequence ; - -: >error-branches-and-quots ( branch/values -- branches quots ) - [ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ; - -: abandon-check ( -- * ) - current-word get - current-word-effect get in>> current-meta-d get zip - [ first quotation-effect? ] filter - >error-branches-and-quots - invalid-quotation-input ; - -:: check-variable ( actual-count declared-count variable -- difference ) - actual-count declared-count - - variable [ - variable current-effect-variables get at* nip - [ variable current-effect-variables get at - ] - [ variable current-effect-variables get set-at 0 ] if - ] [ - dup [ abandon-check ] unless-zero - ] if ; - -: adjust-variable ( diff var -- ) - over 0 >= - [ current-effect-variables get at+ ] - [ 2drop ] if ; inline - -:: (check-input) ( declared actual -- ) - actual terminated?>> [ - actual declared [ in>> length ] bi@ declared in-var>> - [ check-variable ] keep :> ( in-diff in-var ) - actual declared [ out>> length ] bi@ declared out-var>> - [ check-variable ] keep :> ( out-diff out-var ) - { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| - [ - in-var [ in-diff swap adjust-variable ] when* - out-var [ out-diff swap adjust-variable ] when* - ] [ - abandon-check - ] if - ] unless ; - -: infer-value ( value -- effect ) - dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline - -: check-input ( in value -- ) - over quotation-effect? [ - [ second ] dip infer-value (check-input) - ] [ 2drop ] if ; - -: normalize-variables ( -- variables' ) - current-effect-variables get dup values [ - infimum dup 0 < - [ '[ _ - ] assoc-map ] [ drop ] if - ] unless-empty ; - -PRIVATE> - -: infer-polymorphic-vars ( effect -- variables ) - H{ } clone current-effect-variables set - dup current-word-effect set - in>> dup length ensure-d dup current-meta-d set - [ check-input ] 2each - normalize-variables ; - -: check-polymorphic-effect ( word -- ) - current-word get [ - dup current-word set - stack-effect dup { [ in-var>> ] [ out-var>> ] } 1|| - [ infer-polymorphic-vars ] when drop - ] dip current-word set ; - -SYMBOL: infer-polymorphic? -infer-polymorphic? [ t ] initialize diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 270e5695b3..cf0210821e 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -378,7 +378,9 @@ DEFER: eee' [ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with [ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with -[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with + +[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with +[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 7e11ec3edb..53f9e307eb 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces kernel assocs sequences -stack-checker.recursive-state stack-checker.errors ; +stack-checker.recursive-state stack-checker.errors +quotations ; IN: stack-checker.values ! Values @@ -97,9 +98,39 @@ M: input-parameter (literal-value?) drop f ; M: input-parameter (literal) current-word get unknown-macro-input ; +! Argument corresponding to polymorphic declared input of inline combinator + +TUPLE: declared-effect value word effect variables ; + +C: declared-effect + +M: declared-effect (input-value?) value>> input-value? ; + +M: declared-effect (literal-value?) value>> literal-value? ; + +M: declared-effect (literal) value>> literal ; + ! Computed values M: f (input-value?) drop f ; M: f (literal-value?) drop f ; -M: f (literal) current-word get bad-macro-input ; \ No newline at end of file +M: f (literal) current-word get bad-macro-input ; + +SYMBOL: (_) +ERROR: (@) ; + +GENERIC: known>callable ( known -- quot ) + +: ?@ ( x -- y ) + dup callable? [ drop [ (@) ] ] unless ; + +M: object known>callable drop (_) ; +M: literal known>callable value>> ; +M: composed known>callable + [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi + append ; +M: curried known>callable + [ quot>> known known>callable ] [ obj>> known known>callable ] bi + prefix ; + From 63ad397cc1b890b2353a62ca691a6762ab9d9bb7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 11:55:47 -0800 Subject: [PATCH 17/52] tweak recursive call site checking to consider declared-effects equivalent to their wrapped values --- basis/stack-checker/inlining/inlining.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index c83f609868..fd49fa73f0 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -119,9 +119,15 @@ SYMBOL: enter-out : trimmed-enter-out ( label -- stack ) dup enter-out>> trim-stack ; +GENERIC: (undeclared-known) ( value -- known ) +M: object (undeclared-known) ; +M: declared-effect (undeclared-known) value>> known (undeclared-known) ; + +: undeclared-known ( value -- known ) known (undeclared-known) ; + : check-call-site-stack ( label -- ) [ ] [ call-site-stack ] [ trimmed-enter-out ] tri - [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all? + [ dup undeclared-known [ [ undeclared-known ] bi@ = ] [ 2drop t ] if ] 2all? [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ; : check-call ( label -- ) From bbbda64ee74dc4b763e538970909a29811ebfa26 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 16:45:33 -0800 Subject: [PATCH 18/52] add a with-effect-here combinator that determines the effect of a scoped subset of the stack checker --- .../backend/backend-tests.factor | 1 + basis/stack-checker/backend/backend.factor | 11 ++++++-- .../known-words/known-words.factor | 25 +++++++++++++------ .../row-polymorphism/row-polymorphism.factor | 24 +++++++++++++++++- basis/stack-checker/state/state.factor | 4 ++- basis/stack-checker/values/values.factor | 2 ++ 6 files changed, 55 insertions(+), 12 deletions(-) diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index b58998cb49..a714ddf5ab 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -8,6 +8,7 @@ IN: stack-checker.backend.tests V{ } clone \ literals set H{ } clone known-values set 0 input-count set + 0 inner-d-index set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 15fa9f588a..3476866e02 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -6,6 +6,7 @@ continuations assocs combinators compiler.errors accessors math.order definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state stack-checker.dependencies summary ; +FROM: sequences.private => from-end ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; @@ -16,8 +17,13 @@ IN: stack-checker.backend [ #introduce, ] tri ; +: update-inner-d ( new -- ) + inner-d-index get min inner-d-index set ; + : pop-d ( -- obj ) - meta-d [ dup 1array introduce-values ] [ pop ] if-empty ; + meta-d + [ dup 1array introduce-values ] + [ pop meta-d length update-inner-d ] if-empty ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -30,7 +36,8 @@ IN: stack-checker.backend [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri [ introduce-values ] [ meta-d push-all ] bi meta-d push-all - ] when swap tail* ; + ] when + swap from-end [ tail ] [ update-inner-d ] bi ; : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 03c45b9487..203c4c8cb9 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -22,7 +22,8 @@ stack-checker.backend stack-checker.branches stack-checker.transforms stack-checker.dependencies -stack-checker.recursive-state ; +stack-checker.recursive-state +stack-checker.row-polymorphism ; IN: stack-checker.known-words : infer-primitive ( word -- ) @@ -98,15 +99,23 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; -: Pdeclared-effect ( x -- x ) - dup - [ word>> P. ] - [ effect>> P. ] - [ value>> known known>callable P. ] tri ; +! : Pdeclared-effect ( x -- x ) +! "-->" P. +! dup +! [ word>> P. ] +! [ effect>> P. ] +! [ value>> known known>callable P. ] tri +! current-effect P. ; +! +! M: declared-effect infer-call* +! [ Pdeclared-effect +! nip value>> (infer-call) ] +! [ "<--" P. +! word>> P. +! current-effect P. ] bi ; M: declared-effect infer-call* - Pdeclared-effect - nip value>> (infer-call) ; + [ nip dup value>> (infer-call) ] with-effect-here check-declared-effect ; M: input-parameter infer-call* \ call unknown-macro-input ; M: object infer-call* \ call bad-macro-input ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 5f798b1760..5148efba4d 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -1,6 +1,6 @@ ! (c)2010 Joe Groff bsd license USING: accessors arrays assocs combinators combinators.short-circuit -continuations effects fry kernel locals math namespaces +continuations effects fry kernel locals math math.order namespaces quotations sequences splitting stack-checker.backend stack-checker.errors @@ -33,3 +33,25 @@ IN: stack-checker.row-polymorphism ] when* ] each-index ; +:: with-effect-here ( quot -- effect ) + inner-d-index get :> old-inner-d-index + input-count get :> old-input-count + meta-d length :> old-meta-d-length + + old-meta-d-length inner-d-index set + quot call + + inner-d-index get :> new-inner-d-index + input-count get :> new-input-count + + old-meta-d-length new-inner-d-index - + new-input-count old-input-count - + :> in + + meta-d length new-inner-d-index - :> out + + new-inner-d-index old-inner-d-index min inner-d-index set + + in "x" out "x" terminated? get ; inline + +: check-declared-effect ( known effect -- ) + [ known>callable P. ] [ P. ] bi* ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 69eb590d48..3ac6a4531f 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -11,6 +11,7 @@ SYMBOL: terminated? ! Number of inputs current word expects from the stack SYMBOL: input-count +SYMBOL: inner-d-index DEFER: commit-literals @@ -46,4 +47,5 @@ SYMBOL: literals terminated? off V{ } clone \ meta-d set V{ } clone literals set - 0 input-count set ; + 0 input-count set + 0 inner-d-index set ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 53f9e307eb..1590cd886d 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -133,4 +133,6 @@ M: composed known>callable M: curried known>callable [ quot>> known known>callable ] [ obj>> known known>callable ] bi prefix ; +M: declared-effect known>callable + value>> known known>callable ; From b14d59030f8fa7288a96c1931639c54d66640a10 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 17:51:41 -0800 Subject: [PATCH 19/52] add stack variable unification to M\ declared-effect infer-call* --- basis/stack-checker/errors/errors.factor | 6 +--- .../errors/prettyprint/prettyprint.factor | 5 --- .../row-polymorphism/row-polymorphism.factor | 33 ++++++++++++++++++- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index e928c38c88..6a463b5710 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,9 +34,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error word branches quots ; - -ERROR: invalid-effect-variable < inference-error effect ; - -ERROR: effect-variable-can't-have-type < inference-error effect ; +ERROR: invalid-quotation-input < inference-error word quot variables expected actual ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 589bd0a056..5a910af767 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -68,8 +68,3 @@ M: do-not-compile summary M: invalid-quotation-input summary word>> name>> "The input quotations to " " don't match their expected effects" surround ; - -M: invalid-quotation-input error. - dup summary print - [ quots>> ] [ branches>> ] bi quots-and-branches. ; - diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 5148efba4d..406ef7aaae 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -53,5 +53,36 @@ IN: stack-checker.row-polymorphism in "x" out "x" terminated? get ; inline +:: check-variable ( actual-count declared-count variable vars -- difference ) + actual-count declared-count - + variable [ + variable vars at* nip + [ variable vars at - ] + [ variable vars set-at 0 ] if + ] [ drop 0 ] if ; + +: adjust-variable ( diff var vars -- ) + pick 0 >= + [ at+ ] + [ 3drop ] if ; inline + +:: check-variables ( vars declared actual -- ? ) + actual terminated?>> [ t ] [ + actual declared [ in>> length ] bi@ declared in-var>> + [ vars check-variable ] keep :> ( in-diff in-var ) + actual declared [ out>> length ] bi@ declared out-var>> + [ vars check-variable ] keep :> ( out-diff out-var ) + { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| + dup [ + in-var [ in-diff swap vars adjust-variable ] when* + out-var [ out-diff swap vars adjust-variable ] when* + ] when + ] if ; + : check-declared-effect ( known effect -- ) - [ known>callable P. ] [ P. ] bi* ; + 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables + [ 2drop ] [ + [ { [ word>> ] [ known>callable ] [ variables>> ] [ effect>> ] } cleave ] + dip invalid-quotation-input + ] if ; + From 6b9a79159d6143fef25d7f9bb56f7150dece49ed Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 18:07:42 -0800 Subject: [PATCH 20/52] tweak declared-effect to wrap the existing known instead of introducing a new value, so we don't confuse the compiler --- basis/stack-checker/branches/branches.factor | 4 ++-- basis/stack-checker/inlining/inlining.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 2 +- .../row-polymorphism/row-polymorphism.factor | 10 ++++------ basis/stack-checker/values/values.factor | 10 +++++----- 5 files changed, 13 insertions(+), 15 deletions(-) diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 2862b03f20..bb85ec5b1e 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -92,7 +92,7 @@ M: literal infer-branch ] H{ } make-assoc ; M: declared-effect infer-branch - value>> infer-branch ; + known>> infer-branch ; M: callable infer-branch [ @@ -114,7 +114,7 @@ GENERIC: curried/composed? ( known -- ? ) M: object curried/composed? drop f ; M: curried curried/composed? drop t ; M: composed curried/composed? drop t ; -M: declared-effect curried/composed? value>> known curried/composed? ; +M: declared-effect curried/composed? known>> curried/composed? ; : infer-if ( -- ) 2 literals-available? [ diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index fd49fa73f0..697e668409 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -121,7 +121,7 @@ SYMBOL: enter-out GENERIC: (undeclared-known) ( value -- known ) M: object (undeclared-known) ; -M: declared-effect (undeclared-known) value>> known (undeclared-known) ; +M: declared-effect (undeclared-known) known>> (undeclared-known) ; : undeclared-known ( value -- known ) known (undeclared-known) ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 203c4c8cb9..c2c110e6a4 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -115,7 +115,7 @@ M: composed infer-call* ! current-effect P. ] bi ; M: declared-effect infer-call* - [ nip dup value>> (infer-call) ] with-effect-here check-declared-effect ; + [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ; M: input-parameter infer-call* \ call unknown-macro-input ; M: object infer-call* \ call bad-macro-input ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 406ef7aaae..2a5696e380 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -17,12 +17,10 @@ IN: stack-checker.row-polymorphism meta-d length :> d-length n d-length < [ d-length 1 - n - :> n' - n' meta-d [| value | - value word effect variables :> known' - :> value' - known' value' set-known - value' - ] change-nth + n' meta-d nth :> value + value known :> known + known word effect variables :> known' + known' value set-known ] [ word unknown-macro-input ] if ; :: declare-input-effects ( word -- ) diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 1590cd886d..668bdd63a8 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -100,15 +100,15 @@ M: input-parameter (literal) current-word get unknown-macro-input ; ! Argument corresponding to polymorphic declared input of inline combinator -TUPLE: declared-effect value word effect variables ; +TUPLE: declared-effect known word effect variables ; C: declared-effect -M: declared-effect (input-value?) value>> input-value? ; +M: declared-effect (input-value?) known>> (input-value?) ; -M: declared-effect (literal-value?) value>> literal-value? ; +M: declared-effect (literal-value?) known>> (literal-value?) ; -M: declared-effect (literal) value>> literal ; +M: declared-effect (literal) known>> (literal) ; ! Computed values M: f (input-value?) drop f ; @@ -134,5 +134,5 @@ M: curried known>callable [ quot>> known known>callable ] [ obj>> known known>callable ] bi prefix ; M: declared-effect known>callable - value>> known known>callable ; + known>> known>callable ; From 83c81b288fe4ee955baf0c80249583ef2e17de67 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 18:07:59 -0800 Subject: [PATCH 21/52] polymorphize splitting private combinators --- core/splitting/splitting.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 7b805dffe5..7e5c301711 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -61,7 +61,7 @@ PRIVATE> [ drop [ swap [ tail ] unless-zero , ] 2curry ] 3tri if* ; inline recursive -: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline +: split, ( ... seq quot: ( ... elt -- ... ? ) -- ... ) [ 0 ] 2dip (split) ; inline PRIVATE> From 011a39457eb32294beb7405969dab30eeefd9e91 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 18:11:44 -0800 Subject: [PATCH 22/52] clear away some rebar --- .../stack-checker/known-words/known-words.factor | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c2c110e6a4..2c08533ebb 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -99,21 +99,6 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; -! : Pdeclared-effect ( x -- x ) -! "-->" P. -! dup -! [ word>> P. ] -! [ effect>> P. ] -! [ value>> known known>callable P. ] tri -! current-effect P. ; -! -! M: declared-effect infer-call* -! [ Pdeclared-effect -! nip value>> (infer-call) ] -! [ "<--" P. -! word>> P. -! current-effect P. ] bi ; - M: declared-effect infer-call* [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ; From ea4545e3660ad5106cc5b6b421e5481d10aed364 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 18:27:55 -0800 Subject: [PATCH 23/52] improve error message for invalid quotation inputs by referencing each declared-effect to its other references --- basis/stack-checker/errors/errors.factor | 2 +- .../errors/prettyprint/prettyprint.factor | 5 +++++ .../row-polymorphism/row-polymorphism.factor | 20 ++++++++++++------- basis/stack-checker/values/values.factor | 2 +- 4 files changed, 20 insertions(+), 9 deletions(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 6a463b5710..3ca9cab7d9 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,5 +34,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error word quot variables expected actual ; +ERROR: invalid-quotation-input < inference-error word quots branches ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 5a910af767..589bd0a056 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -68,3 +68,8 @@ M: do-not-compile summary M: invalid-quotation-input summary word>> name>> "The input quotations to " " don't match their expected effects" surround ; + +M: invalid-quotation-input error. + dup summary print + [ quots>> ] [ branches>> ] bi quots-and-branches. ; + diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 2a5696e380..cabb69d47c 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -13,21 +13,23 @@ IN: stack-checker.row-polymorphism : ?quotation-effect ( in -- effect/f ) dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; -:: declare-effect-d ( word effect variables n -- ) +:: declare-effect-d ( word effect variables branches n -- ) meta-d length :> d-length n d-length < [ d-length 1 - n - :> n' n' meta-d nth :> value value known :> known - known word effect variables :> known' + known word effect variables branches :> known' known' value set-known + known' branches push ] [ word unknown-macro-input ] if ; :: declare-input-effects ( word -- ) H{ } clone :> variables + V{ } clone :> branches word stack-effect in>> [| in n | in ?quotation-effect [| effect | - word effect variables n declare-effect-d + word effect variables branches n declare-effect-d ] when* ] each-index ; @@ -77,10 +79,14 @@ IN: stack-checker.row-polymorphism ] when ] if ; +: invalid-quotation-input* ( known -- * ) + [ word>> ] [ + branches>> + [ [ known>callable ] { } map-as ] + [ [ effect>> ] { } map-as ] bi + ] bi invalid-quotation-input ; + : check-declared-effect ( known effect -- ) 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables - [ 2drop ] [ - [ { [ word>> ] [ known>callable ] [ variables>> ] [ effect>> ] } cleave ] - dip invalid-quotation-input - ] if ; + [ 2drop ] [ drop invalid-quotation-input* ] if ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 668bdd63a8..714634bdc3 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -100,7 +100,7 @@ M: input-parameter (literal) current-word get unknown-macro-input ; ! Argument corresponding to polymorphic declared input of inline combinator -TUPLE: declared-effect known word effect variables ; +TUPLE: declared-effect known word effect variables branches ; C: declared-effect From 1512ed12f3a6817d7f9174dc97e572eb423859f4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 18:40:58 -0800 Subject: [PATCH 24/52] further improve error message for invalid quotation inputs using a table display with the actual quotation effects determined so far --- basis/stack-checker/errors/errors.factor | 2 +- basis/stack-checker/errors/prettyprint/prettyprint.factor | 3 ++- .../stack-checker/row-polymorphism/row-polymorphism.factor | 4 +++- basis/stack-checker/values/values.factor | 7 +++++-- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 3ca9cab7d9..cfc96e621e 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,5 +34,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error word quots branches ; +ERROR: invalid-quotation-input < inference-error word quots declareds actuals ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 589bd0a056..d3330341e3 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -71,5 +71,6 @@ M: invalid-quotation-input summary M: invalid-quotation-input error. dup summary print - [ quots>> ] [ branches>> ] bi quots-and-branches. ; + [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip + { "Input" "Expected" "Got" } prefix simple-table. ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index cabb69d47c..4fb54506c5 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -83,10 +83,12 @@ IN: stack-checker.row-polymorphism [ word>> ] [ branches>> [ [ known>callable ] { } map-as ] - [ [ effect>> ] { } map-as ] bi + [ [ effect>> ] { } map-as ] + [ [ actual>> ] { } map-as ] tri ] bi invalid-quotation-input ; : check-declared-effect ( known effect -- ) + [ >>actual ] keep 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables [ 2drop ] [ drop invalid-quotation-input* ] if ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 714634bdc3..e2c1ec4707 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -100,9 +100,12 @@ M: input-parameter (literal) current-word get unknown-macro-input ; ! Argument corresponding to polymorphic declared input of inline combinator -TUPLE: declared-effect known word effect variables branches ; +TUPLE: declared-effect known word effect variables branches actual ; -C: declared-effect +C: (declared-effect) declared-effect + +: ( known word effect variables branches -- declared-effect ) + f (declared-effect) ; inline M: declared-effect (input-value?) known>> (input-value?) ; From 4cd6ad840d6917f6784b108923920d96c6ec6b15 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 19:13:41 -0800 Subject: [PATCH 25/52] add tests from old row-polymorphism implementation to stack-checker unit tests --- .../stack-checker/stack-checker-tests.factor | 44 +++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index cf0210821e..6e2d6c467b 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -381,6 +381,7 @@ DEFER: eee' [ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with [ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with +[ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer @@ -404,3 +405,46 @@ DEFER: eee' [ "special" word-prop not ] filter [ "shuffle" word-prop not ] filter ] unit-test + +{ 1 0 } [ [ drop ] each ] must-infer-as +{ 2 1 } [ [ append ] each ] must-infer-as +{ 1 1 } [ [ ] map ] must-infer-as +{ 1 1 } [ [ reverse ] map ] must-infer-as +{ 2 2 } [ [ append dup ] map ] must-infer-as +{ 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as + +{ 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as +{ 3 3 } [ [ dup ] [ over ] if ] must-infer-as +{ 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as +{ 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as + +{ 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as +{ 1 1 } [ [ ] [ f ] if* ] must-infer-as +{ 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as +{ 2 1 } [ [ nip ] [ ] if* ] must-infer-as +{ 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as +{ 1 0 } [ [ drop ] [ ] if* ] must-infer-as + +{ 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as + +! ensure that polymorphic checking works on recursive combinators +FROM: splitting.private => split, ; +{ 2 0 } [ [ member? ] curry split, ] must-infer-as + +[ [ [ write write ] each ] infer ] [ invalid-quotation-input? ] must-fail-with + +[ [ [ ] each ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ dup ] map ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ drop ] map ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ 1 + ] map-index ] infer ] [ invalid-quotation-input? ] must-fail-with + +[ [ [ dup ] [ ] if ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ 2dup ] [ over ] if ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ drop ] [ ] if ] infer ] [ invalid-quotation-input? ] must-fail-with + +[ [ [ ] [ ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ dup ] [ ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ drop ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ ] [ 2dup ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with + From f353b13bbc18f11b238348a35b623c50e33bd3c3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 20:07:30 -0800 Subject: [PATCH 26/52] add unit test from quotation that fails to infer during bootstrap.compiler --- basis/stack-checker/stack-checker-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6e2d6c467b..a2296ca84f 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -448,3 +448,6 @@ FROM: splitting.private => split, ; [ [ [ ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with [ [ [ ] [ 2dup ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +! edge cases in polymorphic checking +{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as + From 66687d6b214106dfc7f496452fa6c433abc4b291 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 20:08:35 -0800 Subject: [PATCH 27/52] reuse @ and _ from fry in placeholders for invalid-quotation-input errors rather than making our own redundant placeholder symbols --- basis/stack-checker/values/values.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index e2c1ec4707..e701f297d7 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel assocs sequences +USING: accessors namespaces fry kernel assocs sequences stack-checker.recursive-state stack-checker.errors quotations ; IN: stack-checker.values @@ -120,15 +120,12 @@ M: f (literal-value?) drop f ; M: f (literal) current-word get bad-macro-input ; -SYMBOL: (_) -ERROR: (@) ; - GENERIC: known>callable ( known -- quot ) : ?@ ( x -- y ) - dup callable? [ drop [ (@) ] ] unless ; + dup callable? [ drop [ @ ] ] unless ; -M: object known>callable drop (_) ; +M: object known>callable drop \ _ ; M: literal known>callable value>> ; M: composed known>callable [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi From 66891135196edeebd21c8486e7640d8f597f0323 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 20:44:50 -0800 Subject: [PATCH 28/52] unify inner-d-index when unifying branches; close a few other leaks where meta-d could have been popped without updating inner-d-index --- basis/stack-checker/backend/backend.factor | 5 ++++- basis/stack-checker/branches/branches.factor | 7 +++++-- basis/stack-checker/transforms/transforms.factor | 2 +- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 3476866e02..1de6ed0e6a 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -42,8 +42,11 @@ IN: stack-checker.backend : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline +: shorten-d ( n -- ) + meta-d shorten-by meta-d length update-inner-d ; + : consume-d ( n -- seq ) - [ ensure-d ] [ meta-d shorten-by ] bi ; + [ ensure-d ] [ shorten-d ] bi ; : output-d ( values -- ) meta-d push-all ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index bb85ec5b1e..570b80f2fd 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -61,7 +61,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ input-count branch-variable ] [ \ meta-d active-variable ] bi + [ input-count branch-variable ] + [ inner-d-index branch-variable infimum inner-d-index set ] + [ \ meta-d active-variable ] tri unify-branches [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ; @@ -80,7 +82,8 @@ SYMBOL: quotations : copy-inference ( -- ) \ meta-d [ clone ] change literals [ clone ] change - input-count [ ] change ; + input-count [ ] change + inner-d-index [ ] change ; GENERIC: infer-branch ( literal -- namespace ) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index cf32792a2e..98e20e5330 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -18,7 +18,7 @@ IN: stack-checker.transforms :: ((apply-transform)) ( quot values stack rstate -- ) rstate recursive-state [ stack quot call-transformer ] with-variable - values [ length meta-d shorten-by ] [ #drop, ] bi + values [ length shorten-d ] [ #drop, ] bi rstate infer-quot ; : literal-values? ( values -- ? ) [ literal-value? ] all? ; From 9e6f84bc245bfa51063cc6079b99198ac5649280 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 21:37:24 -0800 Subject: [PATCH 29/52] declare effect on inputs to infer-if in non-literal case, so we get a better error than "unbalanced drop call/nip call" --- basis/stack-checker/backend/backend.factor | 26 ++++++++++++++++++- basis/stack-checker/branches/branches.factor | 12 +++++++-- .../row-polymorphism/row-polymorphism.factor | 23 ---------------- .../stack-checker/stack-checker-tests.factor | 2 +- 4 files changed, 36 insertions(+), 27 deletions(-) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 1de6ed0e6a..7829f933aa 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -3,7 +3,7 @@ USING: fry arrays generic io io.streams.string kernel math namespaces parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order -definitions sets hints macros stack-checker.state +definitions locals sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state stack-checker.dependencies summary ; FROM: sequences.private => from-end ; @@ -170,3 +170,27 @@ M: bad-call summary : (infer) ( quot -- effect ) [ infer-quot-here ] with-infer drop ; + +: ?quotation-effect ( in -- effect/f ) + dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; + +:: declare-effect-d ( word effect variables branches n -- ) + meta-d length :> d-length + n d-length < [ + d-length 1 - n - :> n' + n' meta-d nth :> value + value known :> known + known word effect variables branches :> known' + known' value set-known + known' branches push + ] [ word unknown-macro-input ] if ; + +:: declare-input-effects ( word -- ) + H{ } clone :> variables + V{ } clone :> branches + word stack-effect in>> [| in n | + in ?quotation-effect [| effect | + word effect variables branches n declare-effect-d + ] when* + ] each-index ; + diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 570b80f2fd..61730d06ec 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry vectors sequences assocs math math.order accessors kernel -combinators quotations namespaces grouping stack-checker.state +combinators quotations namespaces grouping locals stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.values stack-checker.recursive-state ; IN: stack-checker.branches @@ -119,11 +119,19 @@ M: curried curried/composed? drop t ; M: composed curried/composed? drop t ; M: declared-effect curried/composed? known>> curried/composed? ; +:: declare-if-effects ( -- ) + H{ } clone :> variables + V{ } clone :> branches + \ if (( ..a -- ..b )) variables branches 0 declare-effect-d + \ if (( ..a -- ..b )) variables branches 1 declare-effect-d ; + : infer-if ( -- ) 2 literals-available? [ (infer-if) ] [ - drop 2 consume-d + drop 2 ensure-d + declare-if-effects + 2 shorten-d dup [ known curried/composed? ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 4fb54506c5..debe014e33 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -10,29 +10,6 @@ stack-checker.values stack-checker.visitor ; IN: stack-checker.row-polymorphism -: ?quotation-effect ( in -- effect/f ) - dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; - -:: declare-effect-d ( word effect variables branches n -- ) - meta-d length :> d-length - n d-length < [ - d-length 1 - n - :> n' - n' meta-d nth :> value - value known :> known - known word effect variables branches :> known' - known' value set-known - known' branches push - ] [ word unknown-macro-input ] if ; - -:: declare-input-effects ( word -- ) - H{ } clone :> variables - V{ } clone :> branches - word stack-effect in>> [| in n | - in ?quotation-effect [| effect | - word effect variables branches n declare-effect-d - ] when* - ] each-index ; - :: with-effect-here ( quot -- effect ) inner-d-index get :> old-inner-d-index input-count get :> old-input-count diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index a2296ca84f..b8dacdadcc 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -448,6 +448,6 @@ FROM: splitting.private => split, ; [ [ [ ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with [ [ [ ] [ 2dup ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -! edge cases in polymorphic checking +! M\ declared-effect infer-call* didn't properly unify branches { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as From e5c2344ce469b58082ef485faee664cdca24f0de Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 21:56:40 -0800 Subject: [PATCH 30/52] sequences: effects of push-if and push-either were too strict --- core/sequences/sequences.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 314447febf..3e0f102181 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -483,7 +483,7 @@ PRIVATE> : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) (each) all-integers? ; inline -: push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... ) +: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b ) [ keep ] dip rot [ push ] [ 2drop ] if ; inline : selector-for ( quot exemplar -- selector accum ) @@ -498,7 +498,7 @@ PRIVATE> : filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq ) over filter-as ; inline -: push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... ) +: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b ) [ keep swap ] 2dip ? push ; inline : 2selector ( quot -- selector accum1 accum2 ) From 8159a191877ff24d0a1081abbeac76b25b46ef24 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 22:23:24 -0800 Subject: [PATCH 31/52] combine unbalanced-branches-error and invalid-quotation-input into one error --- basis/stack-checker/branches/branches.factor | 10 +++++-- basis/stack-checker/errors/errors.factor | 4 +-- .../errors/prettyprint/prettyprint.factor | 15 ++-------- .../row-polymorphism/row-polymorphism.factor | 6 ++-- .../stack-checker/stack-checker-tests.factor | 28 ++++++++++--------- 5 files changed, 29 insertions(+), 34 deletions(-) diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 61730d06ec..6f8d503c05 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry vectors sequences assocs math math.order accessors kernel +USING: arrays effects fry vectors sequences assocs math math.order accessors kernel combinators quotations namespaces grouping locals stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.values stack-checker.recursive-state ; @@ -45,11 +45,17 @@ SYMBOLS: +bottom+ +top+ ; SYMBOL: quotations +: simple-unbalanced-branches-error ( branches quots -- * ) + [ \ if ] 2dip swap + [ length [ (( ..a -- ..b )) ] replicate ] + [ [ length [ "x" ] bi@ ] { } assoc>map ] bi + unbalanced-branches-error ; + : unify-branches ( ins stacks -- in phi-in phi-out ) zip [ 0 { } { } ] [ [ keys supremum ] [ ] [ balanced? ] tri [ dupd phi-inputs dup phi-outputs ] - [ quotations get unbalanced-branches-error ] + [ quotations get simple-unbalanced-branches-error ] if ] if-empty ; diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index cfc96e621e..58ce20035c 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -10,8 +10,6 @@ ERROR: bad-macro-input < inference-error macro ; ERROR: unknown-macro-input < inference-error macro ; -ERROR: unbalanced-branches-error < inference-error branches quots ; - ERROR: too-many->r < inference-error ; ERROR: too-many-r> < inference-error ; @@ -34,5 +32,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error word quots declareds actuals ; +ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d3330341e3..90d12c6235 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -10,17 +10,6 @@ M: unknown-macro-input summary M: bad-macro-input summary macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ; -M: unbalanced-branches-error summary - drop "Unbalanced branches" ; - -: quots-and-branches. ( quots branches -- ) - zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; - -M: unbalanced-branches-error error. - dup summary print - [ quots>> ] [ branches>> [ length [ "x" ] bi@ ] { } assoc>map ] bi - quots-and-branches. ; - M: too-many->r summary drop "Quotation pushes elements on retain stack without popping them" ; @@ -65,11 +54,11 @@ M: transform-expansion-error error. M: do-not-compile summary word>> name>> "Cannot compile call to " prepend ; -M: invalid-quotation-input summary +M: unbalanced-branches-error summary word>> name>> "The input quotations to " " don't match their expected effects" surround ; -M: invalid-quotation-input error. +M: unbalanced-branches-error error. dup summary print [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip { "Input" "Expected" "Got" } prefix simple-table. ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index debe014e33..89bbbb79f0 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -56,16 +56,16 @@ IN: stack-checker.row-polymorphism ] when ] if ; -: invalid-quotation-input* ( known -- * ) +: complex-unbalanced-branches-error ( known -- * ) [ word>> ] [ branches>> [ [ known>callable ] { } map-as ] [ [ effect>> ] { } map-as ] [ [ actual>> ] { } map-as ] tri - ] bi invalid-quotation-input ; + ] bi unbalanced-branches-error ; : check-declared-effect ( known effect -- ) [ >>actual ] keep 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables - [ 2drop ] [ drop invalid-quotation-input* ] if ; + [ 2drop ] [ drop complex-unbalanced-branches-error ] if ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index b8dacdadcc..8aa2c0c8a2 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -234,10 +234,12 @@ DEFER: blah4 ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as +{ 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as @@ -431,22 +433,22 @@ DEFER: eee' FROM: splitting.private => split, ; { 2 0 } [ [ member? ] curry split, ] must-infer-as -[ [ [ write write ] each ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with -[ [ [ ] each ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ dup ] map ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ drop ] map ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ 1 + ] map-index ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with -[ [ [ dup ] [ ] if ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ 2dup ] [ over ] if ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ drop ] [ ] if ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with -[ [ [ ] [ ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ dup ] [ ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ drop ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ ] [ drop ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with -[ [ [ ] [ 2dup ] if* ] infer ] [ invalid-quotation-input? ] must-fail-with +[ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with ! M\ declared-effect infer-call* didn't properly unify branches { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as From 1669194d04a4b20f3ef09130489b29bb5c75a501 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 8 Mar 2010 03:39:29 -0600 Subject: [PATCH 32/52] Fix typedef typo in opencl --- extra/opencl/ffi/ffi.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/opencl/ffi/ffi.factor b/extra/opencl/ffi/ffi.factor index 90f392a22e..8f0400dd20 100644 --- a/extra/opencl/ffi/ffi.factor +++ b/extra/opencl/ffi/ffi.factor @@ -20,9 +20,9 @@ TYPEDEF: int cl_int TYPEDEF: uint cl_uint TYPEDEF: longlong cl_long TYPEDEF: ulonglong cl_ulong -TYPEDEF: ushort cl_half; -TYPEDEF: float cl_float; -TYPEDEF: double cl_double; +TYPEDEF: ushort cl_half +TYPEDEF: float cl_float +TYPEDEF: double cl_double CONSTANT: CL_CHAR_BIT 8 CONSTANT: CL_SCHAR_MAX 127 From bda1c97d21636d8510b800fc0e28f1c9f2b5e5c5 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 7 Mar 2010 12:17:31 +0100 Subject: [PATCH 33/52] Project Euler : problem 265 --- extra/project-euler/265/265-tests.factor | 5 ++ extra/project-euler/265/265.factor | 63 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 2 +- 3 files changed, 69 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/265/265-tests.factor create mode 100644 extra/project-euler/265/265.factor diff --git a/extra/project-euler/265/265-tests.factor b/extra/project-euler/265/265-tests.factor new file mode 100644 index 0000000000..5e6a7f40c4 --- /dev/null +++ b/extra/project-euler/265/265-tests.factor @@ -0,0 +1,5 @@ +! Copyright (c) 2010 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: project-euler.265 tools.test ; + +[ 209110240768 ] [ euler265 ] unit-test diff --git a/extra/project-euler/265/265.factor b/extra/project-euler/265/265.factor new file mode 100644 index 0000000000..f9ae9393fc --- /dev/null +++ b/extra/project-euler/265/265.factor @@ -0,0 +1,63 @@ +! Copyright (c) 2010 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions project-euler.common sequences sets ; +IN: project-euler.265 + +! http://projecteuler.net/index.php?section=problems&id=265 + +! 2^(N) binary digits can be placed in a circle so that all the N-digit +! clockwise subsequences are distinct. + +! For N=3, two such circular arrangements are possible, ignoring rotations. + +! For the first arrangement, the 3-digit subsequences, in clockwise order, are: +! 000, 001, 010, 101, 011, 111, 110 and 100. + +! Each circular arrangement can be encoded as a number by concatenating +! the binary digits starting with the subsequence of all zeros as the most +! significant bits and proceeding clockwise. The two arrangements for N=3 are +! thus represented as 23 and 29: +! 00010111 _(2) = 23 +! 00011101 _(2) = 29 + +! Calling S(N) the sum of the unique numeric representations, we can see that S(3) = 23 + 29 = 52. + +! Find S(5). + +CONSTANT: N 5 + +: decompose ( n -- seq ) + N iota [ drop [ 2/ ] [ 1 bitand ] bi ] map nip reverse ; + +: bits ( seq -- n ) + 0 [ [ 2 * ] [ + ] bi* ] reduce ; + +: complete ( seq -- seq' ) + unclip decompose append [ 1 bitand ] map ; + +: rotate-bits ( seq -- seq' ) + dup length iota [ cut prepend bits ] with map ; + +: ?register ( acc seq -- ) + complete rotate-bits + dup [ 2 N ^ mod ] map all-unique? [ infimum swap push ] [ 2drop ] if ; + +: add-bit ( seen bit -- seen' t/f ) + over last 2 * + 2 N ^ mod + 2dup swap member? [ drop f ] [ suffix t ] if ; + +: iterate ( acc left seen -- ) + over 0 = [ + nip ?register + ] [ + [ 1 - ] dip + { 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] with with with each + ] if ; + +: euler265 ( -- answer ) + V{ } clone [ 2 N ^ N - { 0 } iterate ] [ sum ] bi ; + +! [ euler265 ] time +! Running time: 0.376389019 seconds + +SOLUTION: euler265 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 4131f41b1f..77017ce578 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -26,7 +26,7 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.134 project-euler.148 project-euler.150 project-euler.151 project-euler.164 project-euler.169 project-euler.173 project-euler.175 project-euler.186 project-euler.188 project-euler.190 project-euler.203 - project-euler.206 project-euler.215 project-euler.255 ; + project-euler.206 project-euler.215 project-euler.255 project-euler.265 ; IN: project-euler Date: Mon, 8 Mar 2010 20:26:36 +0100 Subject: [PATCH 34/52] Use a subclassed tuple with methods instead of quotations --- extra/astar/astar-docs.factor | 38 ++++++++++++++++++++++++++++++++-- extra/astar/astar.factor | 39 +++++++++++++++++++++-------------- 2 files changed, 60 insertions(+), 17 deletions(-) diff --git a/extra/astar/astar-docs.factor b/extra/astar/astar-docs.factor index b8da237ed6..b43f2aba1c 100644 --- a/extra/astar/astar-docs.factor +++ b/extra/astar/astar-docs.factor @@ -3,7 +3,40 @@ USING: help.markup help.syntax ; IN: astar -{ find-path considered } related-words +HELP: astar +{ $description "This tuple must be subclassed and its method " { $link cost } ", " + { $link heuristic } ", and " { $link neighbours } " must be implemented. " + "Alternatively, the " { $link } " word can be used to build a non-specialized version." } ; + +HELP: cost +{ $values + { "from" "a node" } + { "to" "a node" } + { "astar" "an instance of a subclassed " { $link astar } " tuple" } + { "n" "a number" } +} +{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". " + { $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "." +} ; + +HELP: heuristic +{ $values + { "from" "a node" } + { "to" "a node" } + { "astar" "an instance of a subclassed " { $link astar } " tuple" } + { "n" "a number" } +} +{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". " + { $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours." +} ; + +HELP: neighbours +{ $values + { "node" "a node" } + { "astar" "an instance of a subclassed " { $link astar } " tuple" } + { "seq" "a sequence of nodes" } +} +{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ; HELP: { $values @@ -16,7 +49,8 @@ HELP: { $snippet "neighbours" } " one builds the list of neighbours. The " { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent " "respectively the cost for transitioning from a node to one of its neighbour, " - "and the underestimated cost for going from a node to the target." + "and the underestimated cost for going from a node to the target. This solution " + "may not be as efficient as subclassing the " { $link astar } " tuple." } ; HELP: find-path diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor index 1912b6af21..45f8aaa86e 100644 --- a/extra/astar/astar.factor +++ b/extra/astar/astar.factor @@ -5,44 +5,48 @@ IN: astar ! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A* +TUPLE: astar g in-closed-set ; +GENERIC: cost ( from to astar -- n ) +GENERIC: heuristic ( from to astar -- n ) +GENERIC: neighbours ( node astar -- seq ) + > at* [ over open-set>> heap-delete ] [ drop ] if [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ; : add-to-open-set ( node astar -- ) - [ g>> at ] 2keep - [ [ goal>> ] [ heuristic>> call( n1 n2 -- c ) ] bi + ] 2keep + [ astar>> g>> at ] 2keep + [ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep (add-to-open-set) ; : ?add-to-open-set ( node astar -- ) - 2dup in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ; + 2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ; : move-to-closed-set ( node astar -- ) - [ in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ; + [ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ; : get-first ( astar -- node ) [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ; : set-g ( origin g node astar -- ) - [ [ origin>> set-at ] [ g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ; + [ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ; : cost-through ( origin node astar -- cost ) - [ cost>> call( n1 n2 -- c ) ] [ nip g>> at ] 3bi + ; + [ astar>> cost ] [ nip astar>> g>> at ] 3bi + ; : ?set-g ( origin node astar -- ) [ cost-through ] 3keep [ swap ] 2dip - 3dup g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ; + 3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ; : build-path ( target astar -- path ) [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ; : handle ( node astar -- ) - dupd [ neighbours>> call( node -- neighbours ) ] keep [ ?set-g ] curry with each ; + dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ; : (find-path) ( astar -- path/f ) dup open-set>> heap-empty? [ @@ -53,20 +57,25 @@ TUPLE: astar neighbours heuristic cost : (init) ( from to astar -- ) swap >>goal - H{ } clone >>g + H{ } clone over astar>> (>>g) + H{ } clone over astar>> (>>in-closed-set) H{ } clone >>origin H{ } clone >>in-open-set - H{ } clone >>in-closed-set >>open-set - [ 0 ] 2dip [ (add-to-open-set) ] [ g>> set-at ] 3bi ; + [ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ; + +TUPLE: astar-simple < astar cost heuristic neighbours ; +M: astar-simple cost cost>> call( n1 n2 -- c ) ; +M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ; +M: astar-simple neighbours neighbours>> call( n -- neighbours ) ; PRIVATE> : find-path ( start target astar -- path/f ) - [ (init) ] [ (find-path) ] bi ; + (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ; : ( neighbours cost heuristic -- astar ) - astar new swap >>heuristic swap >>cost swap >>neighbours ; + astar-simple new swap >>heuristic swap >>cost swap >>neighbours ; : considered ( astar -- considered ) in-closed-set>> keys ; From 5597ee691f2894e8f92771fe150c3d88a3681613 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 17:17:47 -0800 Subject: [PATCH 35/52] add documentation about stack effect variable syntax and the effect on the stack checker --- basis/stack-checker/stack-checker-docs.factor | 2 ++ core/effects/effects-docs.factor | 16 +++++++++++----- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5ba70ed181..4fa66f7f38 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -27,6 +27,8 @@ ARTICLE: "inference-combinators" "Combinator stack effects" { "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." } } "If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +{ $heading "Input stack effects" } +"Inline combinators will verify the stack effect of their input quotations if they are declared in the combinator's stack effect. See " { $link "effects-variables" } " for details." { $heading "Examples" } { $subheading "Calling a combinator" } "The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 134faea027..df9f6401a2 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math strings words kernel combinators ; +USING: help.markup help.syntax math strings words kernel combinators sequences ; IN: effects ARTICLE: "effects" "Stack effect declarations" @@ -6,11 +6,9 @@ ARTICLE: "effects" "Stack effect declarations" { $code "( input1 input2 ... -- output1 ... )" } "Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:" { $synopsis + } -"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:" +"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration. If the number of inputs or outputs depends on the stack effects of quotation parameters, " { $link "effects-variables" } " can be used to declare this:" { $synopsis while } -"Only the number of inputs and outputs carries semantic meaning." -$nl -"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "." +"For words that are not " { $link POSTPONE: inline } ", only the number of inputs and outputs carries semantic meaning, and effect variables are ignored. However, nested quotation declarations are enforced for inline words. Nested quotation declarations are optional for non-recursive inline combinators and only provide better error messages. However, quotation inputs to " { $link POSTPONE: recursive } " combinators must have an effect declared. See " { $link "inference-recursive-combinators" } "." $nl "In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters." $nl @@ -29,9 +27,17 @@ $nl { { $snippet "loc" } "a screen location specified as a two-element array holding x and y co-ordinates" } { { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" } { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } + { { $snippet ".." } { "indicates " { $link "effects-variables" } ". only valid as the first input or first output" } } } { $see-also "inference" } ; +ARTICLE: "effects-variables" "Stack effect variables" +{ $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, while " { $link each } " inputs elements of its sequence to its quotation, the quotation can also manipulate values on the stack below the element, as long as it leaves the same number of elements on the stack. This ability is used to implement " { $link reduce } " in terms of " { $snippet "each" } ". This variable stack effect is indicated by starting the list of inputs and outputs with a name starting with " { $snippet ".." } ":" +{ $synopsis each } +"In combinators with multiple quotation inputs, the number of inputs or outputs represented by a particular " { $snippet ".." } " name must match. For example, the predicate for a " { $link while } " loop can take an arbitrary number of inputs and leave an arbitrary number of outputs on the stack in addition to the predicate result; however, for the loop to leave the stack balanced, the body of the while loop must consume all of the predicate's outputs and leave a number of its own outputs equal to the initial number of stack values before the predicate was called. This is expressed with the following stack effect:" +{ $synopsis while } +"Stack effect variables can only occur as the first input or first output of a stack effect; names starting in " { $snippet ".." } " cause a syntax error if they occur elsewhere in the effect. For words that are not " { $link POSTPONE: inline } ", effect variables are currently ignored by the stack checker." ; + ABOUT: "effects" HELP: effect From cb656c6e6baefddff8b749eee62edb0b0bacf62a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 18:28:19 -0800 Subject: [PATCH 36/52] add polymorphic stack effects to continuations:recover, attempt-all --- core/continuations/continuations.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 332354e302..687f7153a1 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -119,7 +119,7 @@ SYMBOL: thread-error-hook ] when c> continue-with ; -: recover ( try recovery -- ) +: recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b ) [ [ swap >c call c> drop ] curry ] dip ifcc ; inline : ignore-errors ( quot -- ) @@ -130,7 +130,7 @@ SYMBOL: thread-error-hook ERROR: attempt-all-error ; -: attempt-all ( seq quot -- obj ) +: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj ) over empty? [ attempt-all-error ] [ From 10ca2ba6956f980b77d2e8a0f0f3539470ccf9a4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 18:55:46 -0800 Subject: [PATCH 37/52] add polymorphic effects for lexer:each-token, map-tokens --- core/lexer/lexer.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index e03cae74db..7f6324c251 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -100,10 +100,10 @@ PREDICATE: unexpected-eof < unexpected : (each-token) ( end quot -- pred quot ) [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline -: each-token ( end quot -- ) +: each-token ( ... end quot: ( ... token -- ... ) -- ... ) (each-token) while drop ; inline -: map-tokens ( end quot -- seq ) +: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq ) (each-token) produce nip ; inline : parse-tokens ( end -- seq ) From 21aa4632c844801d7dfc5b1b966a2eae667572d2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 19:32:25 -0800 Subject: [PATCH 38/52] refactor stack-checker.row-polymorphism a little --- .../row-polymorphism/row-polymorphism.factor | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 89bbbb79f0..d8ba12a317 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -10,24 +10,24 @@ stack-checker.values stack-checker.visitor ; IN: stack-checker.row-polymorphism -:: with-effect-here ( quot -- effect ) +:: with-inner-d ( quot -- inner-d ) inner-d-index get :> old-inner-d-index + meta-d length inner-d-index set + quot call + inner-d-index get :> new-inner-d-index + old-inner-d-index new-inner-d-index min inner-d-index set + new-inner-d-index ; inline + +:: with-effect-here ( quot -- effect ) input-count get :> old-input-count meta-d length :> old-meta-d-length - old-meta-d-length inner-d-index set - quot call + quot with-inner-d :> inner-d - inner-d-index get :> new-inner-d-index input-count get :> new-input-count - - old-meta-d-length new-inner-d-index - + old-meta-d-length inner-d - new-input-count old-input-count - + :> in - - meta-d length new-inner-d-index - :> out - - new-inner-d-index old-inner-d-index min inner-d-index set - + meta-d length inner-d - :> out in "x" out "x" terminated? get ; inline :: check-variable ( actual-count declared-count variable vars -- difference ) From 3abf1f1ef72c7063620dc853a05d7ef4fbdf986b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 19:44:01 -0800 Subject: [PATCH 39/52] stack-checker.row-polymorphism: modify check-variables to enforce non-polymorphic stack effects --- .../row-polymorphism/row-polymorphism.factor | 11 ++++++----- basis/stack-checker/stack-checker-tests.factor | 6 ++++++ 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index d8ba12a317..76879a3950 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -30,13 +30,14 @@ IN: stack-checker.row-polymorphism meta-d length inner-d - :> out in "x" out "x" terminated? get ; inline -:: check-variable ( actual-count declared-count variable vars -- difference ) +:: check-variable ( actual-count declared-count variable vars -- difference ? ) actual-count declared-count - variable [ variable vars at* nip [ variable vars at - ] [ variable vars set-at 0 ] if - ] [ drop 0 ] if ; + t + ] [ dup zero? ] if ; : adjust-variable ( diff var vars -- ) pick 0 >= @@ -46,10 +47,10 @@ IN: stack-checker.row-polymorphism :: check-variables ( vars declared actual -- ? ) actual terminated?>> [ t ] [ actual declared [ in>> length ] bi@ declared in-var>> - [ vars check-variable ] keep :> ( in-diff in-var ) + [ vars check-variable ] keep :> ( in-diff in-ok? in-var ) actual declared [ out>> length ] bi@ declared out-var>> - [ vars check-variable ] keep :> ( out-diff out-var ) - { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| + [ vars check-variable ] keep :> ( out-diff out-ok? out-var ) + { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&& dup [ in-var [ in-diff swap vars adjust-variable ] when* out-var [ out-diff swap vars adjust-variable ] when* diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 8aa2c0c8a2..e537a530d2 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -429,6 +429,12 @@ DEFER: eee' { 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as +: strict-each ( seq quot: ( x -- ) -- ) + each ; inline + +{ 1 0 } [ [ drop ] strict-each ] must-infer-as +[ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with + ! ensure that polymorphic checking works on recursive combinators FROM: splitting.private => split, ; { 2 0 } [ [ member? ] curry split, ] must-infer-as From 191ac353fd62d886b5e0ad1e2100444e092a85d3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 23:38:10 -0800 Subject: [PATCH 40/52] generalize stack effects so we can bootstrap with the stricter stack effect checking --- basis/binary-search/binary-search.factor | 2 +- basis/circular/circular.factor | 4 ++-- basis/cocoa/enumeration/enumeration.factor | 6 +++--- basis/compiler/cfg/cfg.factor | 2 +- .../representations/preferred/preferred.factor | 8 ++++---- .../cfg/representations/representations.factor | 2 +- basis/compiler/cfg/rpo/rpo.factor | 4 ++-- .../cfg/ssa/construction/tdmsc/tdmsc.factor | 4 ++-- .../cfg/stacks/finalize/finalize.factor | 2 +- basis/compiler/cfg/tco/tco.factor | 4 ++-- basis/compiler/cfg/utilities/utilities.factor | 6 +++--- .../tree/combinators/combinators.factor | 8 ++++---- .../tree/escape-analysis/nodes/nodes.factor | 2 +- basis/compiler/tree/recursive/recursive.factor | 2 +- basis/compression/huffman/huffman.factor | 2 +- basis/concurrency/mailboxes/mailboxes.factor | 2 +- basis/dlists/dlists.factor | 18 +++++++++--------- basis/documents/documents.factor | 6 +++--- basis/lists/lists.factor | 10 +++++----- basis/math/rectangles/rectangles.factor | 2 +- basis/regexp/regexp.factor | 6 +++--- basis/sequences/deep/deep.factor | 16 ++++++++-------- basis/sequences/parser/parser.factor | 6 +++--- basis/sorting/insertion/insertion.factor | 2 +- basis/stack-checker/backend/backend.factor | 2 +- basis/tools/disassembler/udis/udis.factor | 2 +- core/assocs/assocs.factor | 2 +- core/combinators/combinators.factor | 2 +- core/generic/math/math.factor | 4 ++-- extra/gpu/buffers/buffers.factor | 8 ++++---- extra/math/matrices/simd/simd.factor | 4 ++-- 31 files changed, 75 insertions(+), 75 deletions(-) diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index 89a300202a..83bf9f13f4 100644 --- a/basis/binary-search/binary-search.factor +++ b/basis/binary-search/binary-search.factor @@ -21,7 +21,7 @@ DEFER: (search) : keep-searching ( seq quot -- slice ) [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline -: (search) ( quot: ( elt -- <=> ) seq -- i elt ) +: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt ) dup length 1 <= [ finish ] [ diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index ccb70c617f..0e1fe47fbb 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -64,7 +64,7 @@ TUPLE: circular-iterator > ] [ circular>> ] bi nth ] dip call ] 2keep rot [ [ dup n>> >>last-start ] dip ] when over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [ @@ -75,5 +75,5 @@ TUPLE: circular-iterator PRIVATE> -: circular-while ( circular quot: ( obj -- ? ) -- ) +: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... ) [ clone ] dip [ ] dip (circular-while) ; inline diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index c7bdf625d9..f4d1053f0a 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 @ ] with-destructors ; inline -:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) +:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... ) object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count items-count 0 = [ state itemsPtr>> [ items-count id ] [ stackbuf ] if* :> items @@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 object quot state stackbuf count (NSFastEnumeration-each) ] unless ; inline recursive -: NSFastEnumeration-each ( object quot -- ) +: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... ) [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline -: NSFastEnumeration-map ( object quot -- vector ) +: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector ) NS-EACH-BUFFER-SIZE [ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 5d815e3b0f..79f3b0d1fb 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -39,7 +39,7 @@ predecessors-valid? dominance-valid? loops-valid? ; : predecessors-changed ( cfg -- cfg ) f >>predecessors-valid? ; -: with-cfg ( cfg quot: ( cfg -- ) -- ) +: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b ) [ dup cfg ] dip with-variable ; inline TUPLE: mr { instructions array } word label ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 726521cfe1..9ba78dbf46 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -67,16 +67,16 @@ PRIVATE> tri ] with-compilation-unit -: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- ) +: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... ) [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline -: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- ) +: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... ) [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline -: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- ) +: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... ) [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline -: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- ) +: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b ) '[ [ basic-block set ] [ [ diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index 005fe8c90b..b14390e980 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/basis/compiler/cfg/representations/representations.factor @@ -187,7 +187,7 @@ SYMBOLS: renaming-set needs-renaming? ; : record-renaming ( from to -- ) 2array renaming-set get push needs-renaming? on ; -:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- ) +:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b ) vreg rep-of :> preferred preferred required eq? [ vreg no-renaming ] diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index b6322730ee..b569327c83 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -38,8 +38,8 @@ SYMBOL: visited [ drop basic-block set ] [ change-instructions drop ] 2bi ; inline -: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' ) +: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' ) dupd '[ _ optimize-basic-block ] each-basic-block ; inline : needs-post-order ( cfg -- cfg' ) - dup post-order drop ; \ No newline at end of file + dup post-order drop ; diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 4b459e90fb..837b41e47f 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -47,7 +47,7 @@ SYMBOLS: visited merge-sets levels again? ; tmp dom-parent to tmp walk ] [ lnode ] if ; -: each-incoming-j-edge ( bb quot: ( from to -- ) -- ) +: each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... ) [ [ predecessors>> ] keep ] dip '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline @@ -101,7 +101,7 @@ PRIVATE> [ compute-merge-set-loop ] tri ; -: merge-set-each ( bbs quot: ( bb -- ) -- ) +: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... ) [ (merge-set) ] dip '[ swap _ [ drop ] if ] 2each ; inline diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index f1f7880c90..ad3453704b 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -27,7 +27,7 @@ IN: compiler.cfg.stacks.finalize to dead-in to live-in to anticip-in assoc-diff assoc-diff assoc-diff ; -: each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) +: each-insertion ( ... assoc bb quot: ( ... vreg loc -- ... ) -- ... ) '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline ERROR: bad-peek dst loc ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 810b901013..bd8a7cf754 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -29,7 +29,7 @@ IN: compiler.cfg.tco : word-tail-call? ( bb -- ? ) instructions>> penultimate ##call? ; -: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- ) +: convert-tail-call ( ..a bb quot: ( ..a insn -- ..a tail-insn ) -- ..b ) '[ instructions>> [ pop* ] [ pop ] [ ] tri @@ -65,4 +65,4 @@ IN: compiler.cfg.tco : optimize-tail-calls ( cfg -- cfg' ) dup [ optimize-tail-call ] each-basic-block - cfg-changed predecessors-changed ; \ No newline at end of file + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 3710f4974b..bee2226ec4 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -65,14 +65,14 @@ SYMBOL: visited : cfg-has-phis? ( cfg -- ? ) post-order [ has-phis? ] any? ; -: if-has-phis ( bb quot: ( bb -- ) -- ) +: if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b ) [ dup has-phis? ] dip [ drop ] if ; inline -: each-phi ( bb quot: ( ##phi -- ) -- ) +: each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... ) [ instructions>> ] dip '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline -: each-non-phi ( bb quot: ( insn -- ) -- ) +: each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... ) [ instructions>> ] dip '[ dup ##phi? [ drop ] _ if ] each ; inline diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 1fffa06336..69c48c5f94 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -5,7 +5,7 @@ arrays stack-checker.inlining namespaces compiler.tree math.order ; IN: compiler.tree.combinators -: each-node ( nodes quot: ( node -- ) -- ) +: each-node ( ... nodes quot: ( ... node -- ... ) -- ... ) dup dup '[ _ [ dup #branch? [ @@ -18,7 +18,7 @@ IN: compiler.tree.combinators ] bi ] each ; inline recursive -: map-nodes ( nodes quot: ( node -- node' ) -- nodes ) +: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes ) dup dup '[ @ dup #branch? [ @@ -30,7 +30,7 @@ IN: compiler.tree.combinators ] if ] map-flat ; inline recursive -: contains-node? ( nodes quot: ( node -- ? ) -- ? ) +: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? ) dup dup '[ _ keep swap [ drop t ] [ dup #branch? [ @@ -49,7 +49,7 @@ IN: compiler.tree.combinators : sift-children ( seq flags -- seq' ) zip [ nip ] assoc-filter keys ; -: until-fixed-point ( #recursive quot: ( node -- ) -- ) +: until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... ) over label>> t >>fixed-point drop [ with-scope ] 2keep over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor index 3451750a34..4c9dc1ade7 100644 --- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor +++ b/basis/compiler/tree/escape-analysis/nodes/nodes.factor @@ -10,7 +10,7 @@ GENERIC: escape-analysis* ( node -- ) SYMBOL: next-node -: each-with-next ( seq quot: ( elt -- ) -- ) +: each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... ) dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline : (escape-analysis) ( node -- ) diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index bc6243e138..af76cda903 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -102,7 +102,7 @@ SYMBOL: changed? recursive-nesting get pop* ] each ; -: while-changing ( quot: ( -- ) -- ) +: while-changing ( ... quot: ( ... -- ... ) -- ... ) changed? off [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ; inline recursive diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 9922048009..0c3db04993 100644 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -30,7 +30,7 @@ TUPLE: huffman-code [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ] [ huffman-code code>> free-bits neg 2^ /i 1array ] if ; -:: huffman-each ( tdesc quot: ( huffman-code -- ) -- ) +:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... ) :> code tdesc [ diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 221a5a1fa3..e245f93bd5 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -23,7 +23,7 @@ TUPLE: mailbox threads data ; : wait-for-mailbox ( mailbox timeout -- ) [ threads>> ] dip "mailbox" wait ; -:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) +:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... ) mailbox data>> pred dlist-any? [ mailbox timeout wait-for-mailbox mailbox timeout pred block-unless-pred diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 317ed81e3e..44140d3109 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -54,16 +54,16 @@ M: dlist-node node-value obj>> ; : set-front-to-back ( dlist -- ) dup front>> [ dup back>> >>front ] unless drop ; inline -: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? ) +: (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f ? ) over [ [ call ] 2keep rot [ drop t ] [ [ next>> ] dip (dlist-find-node) ] if ] [ 2drop f f ] if ; inline recursive -: dlist-find-node ( dlist quot -- node/f ? ) +: dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f ? ) [ front>> ] dip (dlist-find-node) ; inline -: dlist-each-node ( dlist quot -- ) +: dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... ) '[ @ f ] dlist-find-node 2drop ; inline : unlink-node ( dlist-node -- ) @@ -114,10 +114,10 @@ M: dlist pop-back* ( dlist -- ) ] keep normalize-front ; -: dlist-find ( dlist quot -- obj/f ? ) +: dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? ) '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline -: dlist-any? ( dlist quot -- ? ) +: dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? ) dlist-find nip ; inline M: dlist deque-member? ( value dlist -- ? ) @@ -130,7 +130,7 @@ M: dlist delete-node ( dlist-node dlist -- ) [ drop unlink-node ] } cond ; -: delete-node-if* ( dlist quot -- obj/f ? ) +: delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? ) dupd dlist-find-node [ dup [ [ swap delete-node ] keep obj>> t @@ -141,7 +141,7 @@ M: dlist delete-node ( dlist-node dlist -- ) 2drop f f ] if ; inline -: delete-node-if ( dlist quot -- obj/f ) +: delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ) '[ obj>> @ ] delete-node-if* drop ; inline M: dlist clear-deque ( dlist -- ) @@ -149,7 +149,7 @@ M: dlist clear-deque ( dlist -- ) f >>back drop ; -: dlist-each ( dlist quot -- ) +: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... ) '[ obj>> @ ] dlist-each-node ; inline : dlist>seq ( dlist -- seq ) @@ -157,7 +157,7 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; -: dlist-filter ( dlist quot -- dlist' ) +: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' ) over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline M: dlist clone diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index dcd1bf5820..e84a993eea 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -55,12 +55,12 @@ TUPLE: document < model locs undos redos inside-undo? ; to first line# = [ to second ] [ line# document doc-line length ] if ; -: each-line ( from to quot -- ) +: each-line ( ... from to quot: ( ... line -- ... ) -- ... ) 2over = [ 3drop ] [ [ [ first ] bi@ [a,b] ] dip each ] if ; inline -: map-lines ( from to quot -- results ) +: map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results ) collector [ each-line ] dip ; inline : start/end-on-line ( from to line# document -- n1 n2 ) @@ -109,7 +109,7 @@ CONSTANT: doc-start { 0 0 } : entire-doc ( document -- start end document ) [ [ doc-start ] dip doc-end ] keep ; -: with-undo ( document quot: ( document -- ) -- ) +: with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b ) [ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline PRIVATE> diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 29adcd47d6..bef9261468 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -55,16 +55,16 @@ M: object nil? drop f ; PRIVATE> -: leach ( list quot: ( elt -- ) -- ) +: leach ( ... list quot: ( ... elt -- ... ) -- ... ) over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive -: lmap ( list quot: ( elt -- ) -- result ) +: lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result ) over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive -: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) +: foldl ( ... list identity quot: ( ... obj1 obj2 -- ... obj ) -- ... result ) swapd leach ; inline -:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) +:: foldr ( ... list identity quot: ( ... obj1 obj2 -- ... obj ) -- ... result ) list nil? [ identity ] [ list cdr identity quot foldr list car quot call @@ -87,7 +87,7 @@ PRIVATE> : sequence>list ( sequence -- list ) nil [ swons ] reduce ; -: lmap>array ( list quot -- array ) +: lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array ) collector [ leach ] dip { } like ; inline : list>array ( list -- array ) diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index bfde391884..db3794cbb0 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -20,7 +20,7 @@ SYNTAX: RECT: scan-object scan-object suffix! ; : rect-center ( rect -- center ) rect-bounds 2 v/n v+ ; -: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- ) +: with-rect-extents ( ..a+b rect1 rect2 loc-quot: ( ..a loc1 loc2 -- ..c ) ext-quot: ( ..b ext1 ext2 -- ..d ) -- ..c+d ) [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline : ( loc ext -- rect ) over [v-] ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 0b387acd2a..e5ac1df151 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -69,7 +69,7 @@ PRIVATE> dup next-match>> execute( i string regexp -- i start end ? ) ; inline -:: (each-match) ( i string regexp quot: ( start end string -- ) -- ) +:: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... ) i string regexp do-next-match [| i' start end | start end string quot call i' string regexp quot (each-match) @@ -80,10 +80,10 @@ PRIVATE> PRIVATE> -: each-match ( string regexp quot: ( start end string -- ) -- ) +: each-match ( ... string regexp quot: ( ... start end string -- ... ) -- ... ) [ prepare-match-iterator ] dip (each-match) ; inline -: map-matches ( string regexp quot: ( start end string -- obj ) -- seq ) +: map-matches ( ... string regexp quot: ( ... start end string -- ... obj ) -- ... seq ) collector [ each-match ] dip >array ; inline : all-matching-slices ( string regexp -- seq ) diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index c79d0b2002..6238962b6c 100644 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -12,30 +12,30 @@ M: integer branch? drop f ; M: string branch? drop f ; M: object branch? drop f ; -: deep-each ( obj quot: ( elt -- ) -- ) +: deep-each ( ... obj quot: ( ... elt -- ... ) -- ... ) [ call ] 2keep over branch? [ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive -: deep-map ( obj quot: ( elt -- elt' ) -- newobj ) +: deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj ) [ call ] keep over branch? [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive -: deep-filter ( obj quot: ( elt -- ? ) -- seq ) +: deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq ) over [ selector [ deep-each ] dip ] dip dup branch? [ like ] [ drop ] if ; inline recursive -: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? ) +: (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? ) [ call ] 2keep rot [ drop t ] [ over branch? [ [ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean ] [ 2drop f f ] if ] if ; inline recursive -: deep-find ( obj quot -- elt ) (deep-find) drop ; inline +: deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline -: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline +: deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline -: deep-all? ( obj quot -- ? ) +: deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) '[ @ not ] deep-any? not ; inline : deep-member? ( obj seq -- ? ) @@ -48,7 +48,7 @@ M: object branch? drop f ; _ swap dup branch? [ subseq? ] [ 2drop f ] if ] deep-find >boolean ; -: deep-map! ( obj quot: ( elt -- elt' ) -- obj ) +: deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj ) over branch? [ '[ _ [ call ] keep over [ deep-map! drop ] dip ] map! ] [ drop ] if ; inline recursive diff --git a/basis/sequences/parser/parser.factor b/basis/sequences/parser/parser.factor index 44fa75239c..322d4cf488 100644 --- a/basis/sequences/parser/parser.factor +++ b/basis/sequences/parser/parser.factor @@ -39,7 +39,7 @@ TUPLE: sequence-parser sequence n ; : get+increment ( sequence-parser -- char/f ) [ current ] [ advance drop ] bi ; inline -:: skip-until ( sequence-parser quot: ( obj -- ? ) -- ) +:: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... ) sequence-parser current [ sequence-parser quot call [ sequence-parser advance quot skip-until ] unless @@ -47,7 +47,7 @@ TUPLE: sequence-parser sequence n ; : sequence-parse-end? ( sequence-parser -- ? ) current not ; -: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) +: take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f ) over sequence-parse-end? [ 2drop f ] [ @@ -56,7 +56,7 @@ TUPLE: sequence-parser sequence n ; [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like ] if ; inline -: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) +: take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f ) [ not ] compose take-until ; inline : ( from to seq -- slice/f ) diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index b7fefcad63..577d2f0b67 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -2,7 +2,7 @@ USING: locals sequences kernel math ; IN: sorting.insertion = [ n n 1 - seq exchange diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 7829f933aa..1e7ae5a9f3 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -136,7 +136,7 @@ M: bad-call summary : infer-r> ( n -- ) consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; -: consume/produce ( effect quot: ( inputs outputs -- ) -- ) +: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b ) '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index ae8827e093..5e46a34682 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -103,7 +103,7 @@ FUNCTION: c-string ud_lookup_mnemonic ( int c ) ; dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; -: with-ud ( quot: ( ud -- ) -- ) +: with-ud ( ..a quot: ( ..a ud -- ..b ) -- ..b ) [ [ [ ] dip call ] with-destructors ] with-code-blocks ; inline SINGLETON: udis-disassembler diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e8ed1637e6..b0509b27cb 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -44,7 +44,7 @@ M: assoc assoc-like drop ; inline : substituter ( assoc -- quot ) [ ?at drop ] curry ; inline -: with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) ) +: with-assoc ( assoc quot: ( ..a value key assoc -- ..b ) -- quot: ( ..a key value -- ..b ) ) curry [ swap ] prepose ; inline PRIVATE> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 7b9481825b..d14564f7b2 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -193,5 +193,5 @@ M: hashtable hashcode* [ assoc-hashcode ] [ nip assoc-size ] if ] recursive-hashcode ; -: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) ) +: to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) ) [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 297684014b..277f40c34f 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -74,7 +74,7 @@ PRIVATE> SYMBOL: generic-word -: make-math-method-table ( classes quot: ( class -- quot ) -- alist ) +: make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist ) [ bootstrap-words ] dip [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline @@ -93,7 +93,7 @@ SYMBOL: generic-word : tuple-dispatch ( picker alist -- alist' ) swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; -: math-dispatch-step ( picker quot: ( class -- quot ) -- quot ) +: math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot ) [ [ { bignum float fixnum } ] dip make-math-method-table ] [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi tuple swap 2array prefix tag-dispatch ; inline diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index bc6f089db9..1f764cdfec 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/extra/gpu/buffers/buffers.factor @@ -132,7 +132,7 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size from-buffer-ptr offset>> to-buffer-ptr offset>> size glCopyBufferSubData ; -:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- ) +:: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b ) buffer bind-buffer :> target target access gl-access glMapBuffer @@ -140,15 +140,15 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size target glUnmapBuffer drop ; inline -:: with-bound-buffer ( buffer target quot: ( -- ) -- ) +:: with-bound-buffer ( ..a buffer target quot: ( ..a -- ..b ) -- ..b ) target gl-target buffer glBindBuffer quot call ; inline -: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- ) +: with-buffer-ptr ( ..a buffer-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b ) [ [ offset>> ] [ buffer>> handle>> ] bi ] 2dip with-bound-buffer ; inline -: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- ) +: with-gpu-data-ptr ( ..a gpu-data-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b ) pick buffer-ptr? [ with-buffer-ptr ] [ [ gl-target 0 glBindBuffer ] dip call ] if ; inline diff --git a/extra/math/matrices/simd/simd.factor b/extra/math/matrices/simd/simd.factor index 01d831d6b0..26ad8bb4d7 100644 --- a/extra/math/matrices/simd/simd.factor +++ b/extra/math/matrices/simd/simd.factor @@ -28,7 +28,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline c1 c2 c3 c4 columns 4 set-firstn-unsafe c ; inline -: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c ) +: make-matrix4 ( ..a quot: ( ..a -- ..b c1 c2 c3 c4 ) -- ..b c ) matrix4 (struct) swap dip set-columns ; inline :: 2map-columns ( a b quot -- c ) @@ -42,7 +42,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline a4 b4 quot call ] make-matrix4 ; inline -: map-columns ( a quot -- c ) +: map-columns ( ... a quot: ( ... col -- ... newcol ) -- ... c ) '[ columns _ 4 napply ] make-matrix4 ; inline PRIVATE> From bcbc7632c60680b014d9943f7ac7e3be91e058f6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 8 Mar 2010 23:46:20 -0800 Subject: [PATCH 41/52] fix stack effects in compiler tests --- basis/compiler/tests/curry.factor | 2 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tree/dead-code/dead-code-tests.factor | 2 +- basis/compiler/tree/normalization/normalization-tests.factor | 2 +- .../compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor | 4 ++-- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index ddbd9ba646..4f38cd8290 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -32,7 +32,7 @@ IN: compiler.tests.curry compile-call ] unit-test -: foobar ( quot: ( -- ) -- ) +: foobar ( quot: ( ..a -- ..b ) -- ) [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive [ ] [ [ [ f ] foobar ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index fe67cbbc37..2e305b2c39 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -198,7 +198,7 @@ USE: sorting USE: binary-search USE: binary-search.private -: old-binsearch ( elt quot: ( -- ) seq -- elt quot i ) +: old-binsearch ( elt quot: ( ..a -- ..b ) seq -- elt quot i ) dup length 1 <= [ from>> ] [ diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index d859096e1d..afdd8fed4e 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -168,7 +168,7 @@ IN: compiler.tree.dead-code.tests [ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test -: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i ) +: call-recursive-dce-6 ( i quot: ( ..a -- ..b ) -- i ) dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive [ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 19669c2239..2f250fcf08 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -14,7 +14,7 @@ IN: compiler.tree.normalization.tests [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -: foo ( quot: ( -- ) -- ) call ; inline recursive +: foo ( ..a quot: ( ..a -- ..b ) -- ..b ) call ; inline recursive : recursive-inputs ( nodes -- n ) [ #recursive? ] find nip child>> first in-d>> length ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index d73368867d..e6d42f0289 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -38,10 +38,10 @@ TUPLE: empty-tuple ; } [ [ ] swap [ test-unboxing ] curry unit-test ] each ! A more complicated example -: impeach-node ( quot: ( node -- ) -- ) +: impeach-node ( quot: ( ..a -- ..b ) -- ) [ call ] keep impeach-node ; inline recursive -: bleach-node ( quot: ( node -- ) -- ) +: bleach-node ( quot: ( ..a -- ..b ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive [ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test From e7968ceffc2a29d4248a52078716105b03734aef Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 00:56:07 -0800 Subject: [PATCH 42/52] mop up compiler errors from macosx load-all --- basis/farkup/farkup.factor | 2 +- basis/furnace/auth/auth.factor | 1 + basis/furnace/scopes/scopes.factor | 1 + basis/io/directories/search/search.factor | 2 +- basis/math/matrices/elimination/elimination.factor | 2 +- basis/xml/syntax/syntax.factor | 2 +- basis/xml/tokenize/tokenize.factor | 4 ++-- core/io/io.factor | 2 +- extra/bank/bank.factor | 2 +- extra/benchmark/nbody-simd/nbody-simd.factor | 2 +- extra/benchmark/nbody/nbody.factor | 2 +- extra/bson/writer/writer.factor | 12 ++++++------ extra/irc/client/base/base.factor | 2 +- extra/project-euler/085/085.factor | 2 +- 14 files changed, 20 insertions(+), 18 deletions(-) diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 5795438570..7707c2a2c7 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -70,7 +70,7 @@ DEFER: (parse-paragraph) { CHAR: % inline-code } } at ; -: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' ) +: or-simple-title ( ... url title/f quot: ( ... title -- ... title' ) -- ... url title' ) [ "" like dup simple-link-title ] if* ; inline : parse-link ( string -- paragraph-list ) diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 831ec7f8fc..29ab04fe1b 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -14,6 +14,7 @@ furnace.redirection furnace.boilerplate furnace.auth.providers furnace.auth.providers.db ; +FROM: assocs => change-at ; IN: furnace.auth SYMBOL: logged-in-user diff --git a/basis/furnace/scopes/scopes.factor b/basis/furnace/scopes/scopes.factor index daad0dcf91..4d005e8adc 100644 --- a/basis/furnace/scopes/scopes.factor +++ b/basis/furnace/scopes/scopes.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors assocs destructors db.tuples db.types furnace.cache ; +FROM: assocs => change-at ; IN: furnace.scopes TUPLE: scope < server-state namespace changed? ; diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 28d7f63d87..0b69064311 100644 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -41,7 +41,7 @@ TUPLE: directory-iterator path bfs queue ; [ nip ] if ] if ; -:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f ) +:: iterate-directory-entries ( ... iter quot: ( ... obj -- ... obj ) -- ... directory-entry/f ) iter next-directory-entry [ quot call [ iter quot iterate-directory-entries ] unless* diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index c8d5bb7338..6dfcf9f0ca 100644 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -11,7 +11,7 @@ SYMBOL: matrix : nth-row ( row# -- seq ) matrix get nth ; -: change-row ( row# quot: ( seq -- seq ) -- ) +: change-row ( ..a row# quot: ( ..a seq -- ..b seq ) -- ..b ) matrix get swap change-nth ; inline : exchange-rows ( row# row# -- ) matrix get exchange ; diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 4b9900d3b0..c56dd23db7 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -44,7 +44,7 @@ SYNTAX: XML-NS: : each-attrs ( attrs quot -- ) [ values [ interpolated? ] filter ] dip each ; inline -: (each-interpolated) ( item quot: ( interpolated -- ) -- ) +: (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... ) { { [ over interpolated? ] [ call ] } { [ over tag? ] [ [ attrs>> ] dip each-attrs ] } diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index ef8420d66c..8978c660f4 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -59,14 +59,14 @@ HINTS: next* { spot } ; ! with-input-stream implicitly creates a new scope which we use swap [ init-parser call ] with-input-stream ; inline -:: (skip-until) ( quot: ( -- ? ) spot -- ) +:: (skip-until) ( ... quot: ( ... -- ... ? ) spot -- ... ) spot char>> [ quot call [ spot next* quot spot (skip-until) ] unless ] when ; inline recursive -: skip-until ( quot: ( -- ? ) -- ) +: skip-until ( ... quot: ( ... -- ... ? ) -- ... ) spot get (skip-until) ; inline : take-until ( quot -- string ) diff --git a/core/io/io.factor b/core/io/io.factor index 519d6535b9..e3c6a8f26c 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -87,7 +87,7 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- ) +: each-morsel ( ..a handler: ( ..a data -- ..b ) reader: ( ..b -- ..a data ) -- ..a ) [ dup ] compose swap while drop ; inline transaction : process-day ( account date -- ) 2dup accumulate-interest ?pay-interest ; -: each-day ( quot: ( -- ) start end -- ) +: each-day ( ... quot: ( ... day -- ... ) start end -- ... ) 2dup before? [ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day ] [ diff --git a/extra/benchmark/nbody-simd/nbody-simd.factor b/extra/benchmark/nbody-simd/nbody-simd.factor index 37fb1d0ce3..39c2169596 100644 --- a/extra/benchmark/nbody-simd/nbody-simd.factor +++ b/extra/benchmark/nbody-simd/nbody-simd.factor @@ -58,7 +58,7 @@ SPECIALIZED-ARRAY: body body-array{ } output>sequence dup init-bodies ; inline -:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- ) +:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ) bodies [| body i | body each-quot call bodies i 1 + tail-slice [ diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index 256fa9ec28..79a5a131f9 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -58,7 +58,7 @@ TUPLE: nbody-system { bodies array read-only } ; [ ] output>array nbody-system boa dup bodies>> init-bodies ; inline -:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- ) +:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ... ) bodies [| body i | body each-quot call bodies i 1 + tail-slice [ diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index a070579943..2ae8737c70 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -32,22 +32,22 @@ PRIVATE> : ensure-buffer ( -- ) (buffer) drop ; inline -: with-buffer ( quot: ( -- ) -- byte-vector ) +: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector ) [ (buffer) [ reset-buffer ] keep dup ] dip with-output-stream* ; inline -: with-length ( quot: ( -- ) -- bytes-written start-index ) +: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index ) [ (buffer) [ length ] keep ] dip call length swap [ - ] keep ; inline -: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- ) +: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b ) [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap [ call ] dip (buffer) copy ; inline -: with-length-prefix ( quot: ( -- ) -- ) +: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b ) [ INT32-SIZE >le ] (with-length-prefix) ; inline -: with-length-prefix-excl ( quot: ( -- ) -- ) +: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b ) [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline : mdb-special-value? ( value -- ? ) { [ timestamp? ] [ quotation? ] [ mdbregexp? ] - [ oid? ] [ byte-array? ] } 1|| ; inline \ No newline at end of file + [ oid? ] [ byte-array? ] } 1|| ; inline diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor index 318a1ab1e3..8cc083d9dd 100644 --- a/extra/irc/client/base/base.factor +++ b/extra/irc/client/base/base.factor @@ -14,7 +14,7 @@ SYMBOL: current-irc-client : chats> ( -- seq ) irc> chats>> values ; : me? ( string -- ? ) irc> nick>> = ; -: with-irc ( irc-client quot: ( -- ) -- ) +: with-irc ( ..a irc-client quot: ( ..a -- ..b ) -- ..b ) \ current-irc-client swap with-variable ; inline UNION: to-target privmsg notice ; diff --git a/extra/project-euler/085/085.factor b/extra/project-euler/085/085.factor index 9c12367cdf..bc94811a76 100644 --- a/extra/project-euler/085/085.factor +++ b/extra/project-euler/085/085.factor @@ -29,7 +29,7 @@ IN: project-euler.085 : rectangles-count ( a b -- n ) 2dup [ 1 + ] bi@ * * * 4 /i ; inline -:: each-unique-product ( a b quot: ( i j -- ) -- ) +:: each-unique-product ( ... a b quot: ( ... i j -- ... ) -- ... ) a b [a,b] [| i | i b [a,b] [| j | i j quot call From 84aa47610f4f688dd076abf2906e049c1acea78e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 10:22:14 -0800 Subject: [PATCH 43/52] mop up errors from test-all --- basis/regexp/minimize/minimize.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index a6eb4f00a2..08f7b1da58 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -3,6 +3,7 @@ USING: kernel sequences regexp.transition-tables fry assocs accessors locals math sorting arrays sets hashtables regexp.dfa combinators.short-circuit regexp.classes ; +FROM: assocs => change-at ; IN: regexp.minimize : table>state-numbers ( table -- assoc ) @@ -51,7 +52,7 @@ IN: regexp.minimize >hashtable ; -:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj ) +:: (while-changes) ( ..a obj quot: ( ..a obj -- ..b obj' ) comp: ( ..b obj' -- ..a key ) old-key -- ..a obj ) obj quot call :> new-obj new-obj comp call :> new-key new-key old-key = From 8e227bc874e356f1e292ab18d1bad1d48966746a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 9 Mar 2010 15:58:44 -0500 Subject: [PATCH 44/52] Propagation tracks length just like any other read-only slot --- .../tree/propagation/info/info.factor | 35 +++++++------------ .../propagation/recursive/recursive.factor | 3 +- .../tree/propagation/slots/slots.factor | 9 ++--- 3 files changed, 16 insertions(+), 31 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 7f5b9f6fcd..b154845c07 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -31,7 +31,6 @@ class interval literal literal? -length slots ; CONSTANT: null-info T{ value-info f null empty-interval } @@ -74,13 +73,20 @@ UNION: fixed-length array byte-array string ; ] unless ] unless ; +: length-slots ( length class -- slots ) + "slots" word-prop length 1 - f + swap prefix ; + : init-literal-info ( info -- info ) empty-interval >>interval dup literal>> literal-class >>class dup literal>> { { [ dup real? ] [ [a,a] >>interval ] } { [ dup tuple? ] [ tuple-slot-infos >>slots ] } - { [ dup fixed-length? ] [ length >>length ] } + { [ dup fixed-length? ] [ + [ length ] [ class ] bi + length-slots >>slots + ] } [ drop ] } cond ; inline @@ -158,11 +164,11 @@ UNION: fixed-length array byte-array string ; t >>literal? init-value-info ; foldable -: ( value -- info ) +: ( length class -- info ) - object >>class - swap value-info >>length - init-value-info ; foldable + over >>class + [ length-slots ] dip swap >>slots + init-value-info ; : ( slots class -- info ) @@ -185,13 +191,6 @@ DEFER: value-info-intersect DEFER: (value-info-intersect) -: intersect-lengths ( info1 info2 -- length ) - [ length>> ] bi@ { - { [ dup not ] [ drop ] } - { [ over not ] [ nip ] } - [ value-info-intersect ] - } cond ; - : intersect-slot ( info1 info2 -- info ) { { [ dup not ] [ nip ] } @@ -215,7 +214,6 @@ DEFER: (value-info-intersect) [ [ class>> ] bi@ class-and >>class ] [ [ interval>> ] bi@ interval-intersect >>interval ] [ intersect-literals [ >>literal ] [ >>literal? ] bi* ] - [ intersect-lengths >>length ] [ intersect-slots >>slots ] } 2cleave init-value-info ; @@ -236,13 +234,6 @@ DEFER: value-info-union DEFER: (value-info-union) -: union-lengths ( info1 info2 -- length ) - [ length>> ] bi@ { - { [ dup not ] [ nip ] } - { [ over not ] [ drop ] } - [ value-info-union ] - } cond ; - : union-slot ( info1 info2 -- info ) { { [ dup not ] [ nip ] } @@ -261,7 +252,6 @@ DEFER: (value-info-union) [ [ class>> ] bi@ class-or >>class ] [ [ interval>> ] bi@ interval-union >>interval ] [ union-literals [ >>literal ] [ >>literal? ] bi* ] - [ union-lengths >>length ] [ union-slots >>slots ] } 2cleave init-value-info ; @@ -293,7 +283,6 @@ DEFER: (value-info-union) { [ 2dup [ class>> ] bi@ class<= not ] [ f ] } { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] } { [ 2dup literals<= not ] [ f ] } - { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] } { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] } [ t ] } cond 2nip diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index eb4158e756..d4ab697e21 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive [ clone ] dip [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ] [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] - [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] - tri + bi ] if ] if ; diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 18d31985d6..6429928294 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths -UNION: fixed-length-sequence array byte-array string ; - : sequence-constructor? ( word -- ? ) { (byte-array) } member-eq? ; @@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ; } at ; : propagate-sequence-constructor ( #call word -- infos ) - [ in-d>> first ] - [ constructor-output-class ] - bi* value-info-intersect 1array ; + [ in-d>> first value-info ] + [ constructor-output-class ] bi* + 1array ; : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple @@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ; : value-info-slot ( slot info -- info' ) { { [ over 0 = ] [ 2drop fixnum ] } - { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } [ [ 1 - ] [ slots>> ] bi* ?nth ] } cond [ object-info ] unless* ; From 8a52aec6da904f4ea9e5678bb340e19d8a8f06ff Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 13:50:58 -0800 Subject: [PATCH 45/52] effects: docs for , , --- core/effects/effects-docs.factor | 67 +++++++++++++++++++++++++++++++- 1 file changed, 66 insertions(+), 1 deletion(-) diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index df9f6401a2..e97120d26b 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math strings words kernel combinators sequences ; +USING: arrays classes help.markup help.syntax math strings words kernel combinators sequences ; IN: effects ARTICLE: "effects" "Stack effect declarations" @@ -29,8 +29,73 @@ $nl { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } { { $snippet ".." } { "indicates " { $link "effects-variables" } ". only valid as the first input or first output" } } } +"For reflection and metaprogramming, you can use " { $link "syntax-effects" } " to include literal stack effects in your code, or these constructor words to construct stack effect objects at runtime:" +{ $subsections + + + +} +$nl { $see-also "inference" } ; +HELP: +{ $values + { "in" "a sequence of strings or string–type pairs" } + { "out" "a sequence of strings or string–type pairs" } + { "effect" effect } +} +{ $description "Constructs an " { $link effect } " object. Each element of " { $snippet "in" } " and " { $snippet "out" } " must be either a string (which is equivalent to a " { $snippet "name" } " in literal stack effect syntax), or a " { $link pair } " where the first element is a string and the second is either a " { $link class } " or effect (which is equivalent to " { $snippet "name: class" } " or " { $snippet "name: ( nested -- effect )" } " in the literal syntax. If the " { $snippet "out" } " array consists of a single string element " { $snippet "\"*\"" } ", a terminating stack effect will be constructed." } +{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link } " to construct variable stack effects." } +{ $examples +{ $example """USING: effects prettyprint ; +{ "a" "b" } { "c" } .""" """(( a b -- c ))""" } +{ $example """USING: arrays effects prettyprint ; +{ "a" { "b" array } } { "c" } .""" """(( a b: array -- c ))""" } +{ $example """USING: effects prettyprint ; +{ "a" { "b" (( x y -- z )) } } { "c" } .""" """(( a b: ( x y -- z ) -- c ))""" } +{ $example """USING: effects prettyprint ; +{ "a" { "b" (( x y -- z )) } } { "*" } .""" """(( a b: ( x y -- z ) -- * ))""" } +} ; + +HELP: +{ $values + { "in" "a sequence of strings or string–type pairs" } + { "out" "a sequence of strings or string–type pairs" } + { "terminated?" boolean } + { "effect" effect } +} +{ $description "Constructs an " { $link effect } " object like " { $link } ". If " { $snippet "terminated?" } " is true, the value of " { $snippet "out" } " is ignored, and a terminating stack effect is constructed." } +{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link } " to construct variable stack effects." } +{ $examples +{ $example """USING: effects prettyprint ; +{ "a" { "b" (( x y -- z )) } } { "c" } f .""" """(( a b: ( x y -- z ) -- c ))""" } +{ $example """USING: effects prettyprint ; +{ "a" { "b" (( x y -- z )) } } { } t .""" """(( a b: ( x y -- z ) -- * ))""" } +} ; + +HELP: +{ $values + { "in-var" { $maybe string } } + { "in" "a sequence of strings or string–type pairs" } + { "out-var" { $maybe string } } + { "out" "a sequence of strings or string–type pairs" } + { "effect" effect } +} +{ $description "Constructs an " { $link effect } " object like " { $link } ". If " { $snippet "in-var" } " or " { $snippet "out-var" } " are not " { $link f } ", they are used as the names of the " { $link "effects-variables" } " for the inputs and outputs of the effect object." } +{ $examples +{ $example """USING: effects prettyprint ; +f { "a" "b" } f { "c" } .""" """(( a b -- c ))""" } +{ $example """USING: effects prettyprint ; +"x" { "a" "b" } "y" { "c" } .""" """(( ..x a b -- ..y c ))""" } +{ $example """USING: arrays effects prettyprint ; +"y" { "a" { "b" (( ..x -- ..y )) } } "x" { "c" } .""" """(( ..y a b: ( ..x -- ..y ) -- ..x c ))""" } +{ $example """USING: effects prettyprint ; +"." { "a" "b" } f { "*" } .""" """(( ... a b -- * ))""" } +} ; + + +{ } related-words + ARTICLE: "effects-variables" "Stack effect variables" { $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, while " { $link each } " inputs elements of its sequence to its quotation, the quotation can also manipulate values on the stack below the element, as long as it leaves the same number of elements on the stack. This ability is used to implement " { $link reduce } " in terms of " { $snippet "each" } ". This variable stack effect is indicated by starting the list of inputs and outputs with a name starting with " { $snippet ".." } ":" { $synopsis each } From 34b29af2454ca07cceebf17ee970362ddd1c4639 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 15:57:00 -0800 Subject: [PATCH 46/52] non-polymorphic input parameter check was too strict: wouldn't allow ( x -- ) for ( x x -- x ), for example --- .../row-polymorphism/row-polymorphism.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 76879a3950..29ee63bf33 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -37,7 +37,7 @@ IN: stack-checker.row-polymorphism [ variable vars at - ] [ variable vars set-at 0 ] if t - ] [ dup zero? ] if ; + ] [ dup 0 <= ] if ; : adjust-variable ( diff var vars -- ) pick 0 >= diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index e537a530d2..ce2c03264b 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -431,9 +431,18 @@ DEFER: eee' : strict-each ( seq quot: ( x -- ) -- ) each ; inline +: strict-map ( seq quot: ( x -- x' ) -- seq' ) + map ; inline +: strict-2map ( xs ys quot: ( x y -- z ) -- zs ) + 2map ; inline { 1 0 } [ [ drop ] strict-each ] must-infer-as +{ 1 1 } [ [ 1 + ] strict-map ] must-infer-as +{ 1 1 } [ [ ] strict-map ] must-infer-as +{ 2 1 } [ [ + ] strict-2map ] must-infer-as +{ 2 1 } [ [ drop ] strict-2map ] must-infer-as [ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with +[ [ [ 1 + ] strict-2map ] infer ] [ unbalanced-branches-error? ] must-fail-with ! ensure that polymorphic checking works on recursive combinators FROM: splitting.private => split, ; From 7744559a46393b467d595e812eaf92e7340d2453 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Mar 2010 15:15:49 +1300 Subject: [PATCH 47/52] compiler.tree.propagation: clean up --- .../tree/propagation/info/info.factor | 21 ++++++++----------- .../tree/propagation/slots/slots.factor | 2 +- 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index b154845c07..22ea1306d6 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -47,9 +47,7 @@ CONSTANT: object-info T{ value-info f object full-interval } { [ over interval-length 0 > ] [ 3drop f f ] } { [ pick bignum class<= ] [ 2nip >bignum t ] } { [ pick integer class<= ] [ 2nip >fixnum t ] } - { [ pick float class<= ] [ - 2nip dup zero? [ drop f f ] [ >float t ] if - ] } + { [ pick float class<= ] [ 2nip dup zero? [ drop f f ] [ >float t ] if ] } [ 3drop f f ] } cond ] if ; @@ -73,9 +71,11 @@ UNION: fixed-length array byte-array string ; ] unless ] unless ; -: length-slots ( length class -- slots ) - "slots" word-prop length 1 - f - swap prefix ; +: (slots-with-length) ( length class -- slots ) + "slots" word-prop length 1 - f swap prefix ; + +: slots-with-length ( seq -- slots ) + [ length ] [ class ] bi (slots-with-length) ; : init-literal-info ( info -- info ) empty-interval >>interval @@ -83,10 +83,7 @@ UNION: fixed-length array byte-array string ; dup literal>> { { [ dup real? ] [ [a,a] >>interval ] } { [ dup tuple? ] [ tuple-slot-infos >>slots ] } - { [ dup fixed-length? ] [ - [ length ] [ class ] bi - length-slots >>slots - ] } + { [ dup fixed-length? ] [ slots-with-length >>slots ] } [ drop ] } cond ; inline @@ -164,10 +161,10 @@ UNION: fixed-length array byte-array string ; t >>literal? init-value-info ; foldable -: ( length class -- info ) +: ( length class -- info ) over >>class - [ length-slots ] dip swap >>slots + [ (slots-with-length) ] dip swap >>slots init-value-info ; : ( slots class -- info ) diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 6429928294..2602d6d59a 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -23,7 +23,7 @@ IN: compiler.tree.propagation.slots : propagate-sequence-constructor ( #call word -- infos ) [ in-d>> first value-info ] [ constructor-output-class ] bi* - 1array ; + 1array ; : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple From b9bced9a5ed4c9e60c7de80facd48e27c41509b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 18:42:10 -0800 Subject: [PATCH 48/52] update docs for unbalanced-branches-error --- basis/stack-checker/errors/errors-docs.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 9aa7ed0d14..4f1bb28c5e 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -63,15 +63,16 @@ HELP: bad-macro-input } ; HELP: unbalanced-branches-error -{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } -{ $description "Throws an " { $link unbalanced-branches-error } "." } -{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." } -{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } +{ $error-description "Thrown when inference encounters an inline combinator whose input quotations do not match their declared effects, or when it encounters an " { $link if } " or " { $link dispatch } " whose branches do not all exit with the same stack height. See " { $link "inference-combinators" } " and " { $link "inference-branches" } " for details." } { $examples { $code - ": unbalanced-branches-example ( a b c -- )" + ": if-unbalanced-branches-example ( a b c -- )" " [ + ] [ dup ] if ;" } + { $code + ": each-unbalanced-branches-example ( x seq -- x' )" + " [ 3append ] each ;" + } } ; HELP: too-many->r From 4367b15c4a3825448ad53d6763de616ba1731655 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 19:51:04 -0800 Subject: [PATCH 49/52] update help-lint to complain when $quotation effect doesn't match declared effect on corresponding input parameter of stack effect --- basis/help/lint/checks/checks.factor | 25 ++++++++++++++++++++++++- basis/help/lint/lint.factor | 18 ++++++++++-------- 2 files changed, 34 insertions(+), 9 deletions(-) diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 632cdb46e2..85fa50f2b9 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -36,11 +36,27 @@ SYMBOL: vocab-articles first rest [ first ] map ] unless ; +: extract-value-effects ( element -- seq ) + \ $values swap elements dup empty? [ + first rest [ + \ $quotation swap elements dup empty? [ drop f ] [ + first second + ] if + ] map + ] unless ; + : effect-values ( word -- seq ) stack-effect [ in>> ] [ out>> ] bi append [ dup pair? [ first ] when effect>string ] map prune ; +: effect-effects ( word -- seq ) + stack-effect in>> [ + dup pair? + [ second dup effect? [ effect>string ] [ drop f ] if ] + [ drop f ] if + ] map ; + : contains-funky-elements? ( element -- ? ) { $shuffle @@ -70,9 +86,16 @@ SYMBOL: vocab-articles [ effect-values ] [ extract-values ] bi* sequence= - ] + ] } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ; +: check-value-effects ( word element -- ) + [ effect-effects ] + [ extract-value-effects ] + bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all? + [ "$quotation documentation in $values don't match stack effect" simple-lint-error ] + unless ; + : check-nulls ( element -- ) \ $values swap elements null swap deep-member? diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 47b8820f18..7112eb5da9 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs continuations fry help help.lint.checks -help.topics io kernel namespaces parser sequences -source-files.errors vocabs.hierarchy vocabs words classes -locals tools.errors listener ; +USING: assocs combinators continuations fry help +help.lint.checks help.topics io kernel namespaces parser +sequences source-files.errors vocabs.hierarchy vocabs words +classes locals tools.errors listener ; FROM: help.lint.checks => all-vocabs ; FROM: vocabs => child-vocabs ; IN: help.lint @@ -49,10 +49,12 @@ PRIVATE> [ with-file-vocabs ] vocabs-quot set dup word-help [ [ >link ] keep '[ - _ dup word-help - [ check-values ] - [ check-class-description ] - [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri + _ dup word-help { + [ check-values ] + [ check-value-effects ] + [ check-class-description ] + [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] + } 2cleave ] check-something ] [ drop ] if ; From b9004a4fffd05eb45f5d1a5d2de91c7b2c68f554 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 20:29:44 -0800 Subject: [PATCH 50/52] fix up sequences help-lint --- basis/sequences/deep/deep-docs.factor | 12 ++-- core/sequences/sequences-docs.factor | 90 +++++++++++++-------------- core/sequences/sequences.factor | 36 +++++------ 3 files changed, 69 insertions(+), 69 deletions(-) diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor index 6f479e48b6..02d3b9e9ba 100644 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -2,27 +2,27 @@ USING: help.syntax help.markup kernel sequences ; IN: sequences.deep HELP: deep-each -{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... )" } } } { $description "Execute a quotation on each nested element of an object and its children, in preorder." } { $see-also each } ; HELP: deep-map -{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } { "newobj" "the mapped object" } } { $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } { $see-also map } ; HELP: deep-filter -{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "seq" "a sequence" } } { $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } { $see-also filter } ; HELP: deep-find -{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "elt" "an element" } } { $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } { $see-also find } ; HELP: deep-any? -{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } } { $description "Tests whether the given object or any subnode satisfies the given quotation." } { $see-also any? } ; @@ -31,7 +31,7 @@ HELP: flatten { $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; HELP: deep-map! -{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } } +{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } } { $description "Modifies each sub-node of an object in place, in preorder, and returns that object." } { $see-also map! } ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index d40796a4f6..8d6ddf1be9 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -253,15 +253,15 @@ HELP: set-array-nth { $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory. User code must use " { $link set-nth } " instead." } ; HELP: collect -{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } } +{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( ... n -- ... value )" } } { "into" "a sequence of length at least " { $snippet "n" } } } { $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. User code should use " { $link map } " instead." } ; HELP: each -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... x -- ... )" } } } { $description "Applies the quotation to each element of the sequence in order." } ; HELP: reduce -{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." } { $examples { $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" } @@ -269,7 +269,7 @@ HELP: reduce HELP: reduce-index { $values - { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt index -- result )" } } } + { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt index -- ... next )" } } { "result" object } } { $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." } { $examples { $example "USING: sequences prettyprint math ;" "{ 10 50 90 } 0 [ + + ] reduce-index ." @@ -277,7 +277,7 @@ HELP: reduce-index } } ; HELP: accumulate-as -{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -285,7 +285,7 @@ $nl "When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ; HELP: accumulate -{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } { "newseq" "a new array" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -296,7 +296,7 @@ $nl } ; HELP: accumulate! -{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -307,11 +307,11 @@ $nl } ; HELP: map -{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; HELP: map-as -{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." } { $examples "The following example converts a string into an array of one-element strings:" @@ -321,7 +321,7 @@ HELP: map-as HELP: each-index { $values - { "seq" sequence } { "quot" { $quotation "( elt index -- )" } } } + { "seq" sequence } { "quot" { $quotation "( ... elt index -- ... )" } } } { $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." } { $examples { $example "USING: arrays sequences prettyprint ;" "{ 10 20 30 } [ 2array . ] each-index" @@ -330,7 +330,7 @@ HELP: each-index HELP: map-index { $values - { "seq" sequence } { "quot" { $quotation "( elt index -- result )" } } { "newseq" sequence } } + { "seq" sequence } { "quot" { $quotation "( ... elt index -- ... newelt )" } } { "newseq" sequence } } { $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." } { $examples { $example "USING: arrays sequences prettyprint ;" "{ 10 20 30 } [ 2array ] map-index ." @@ -338,13 +338,13 @@ HELP: map-index } } ; HELP: change-nth -{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( elt -- newelt )" } } } +{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } } { $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." } { $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." } { $side-effects "seq" } ; HELP: map! -{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } } +{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } } { $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." } { $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." } { $side-effects "seq" } ; @@ -358,44 +358,44 @@ HELP: max-length { $description "Outputs the maximum of the lengths of the two sequences." } ; HELP: 2each -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } } { $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; HELP: 3each -{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... )" } } } { $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ; HELP: 2reduce { $values { "seq1" sequence } { "seq2" sequence } { "identity" object } - { "quot" { $quotation "( prev elt1 elt2 -- next )" } } + { "quot" { $quotation "( ... prev elt1 elt2 -- ... next )" } } { "result" "the final result" } } { $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ; HELP: 2map -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; HELP: 3map -{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; HELP: 2map-as -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; HELP: 3map-as -{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; HELP: 2all? -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... ? )" } } { "?" "a boolean" } } { $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; HELP: find { $values { "seq" sequence } - { "quot" { $quotation "( elt -- ? )" } } + { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or " { $link f } } { "elt" "the first matching element, or " { $link f } } } { $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ; @@ -403,51 +403,51 @@ HELP: find HELP: find-from { $values { "n" "a starting index" } { "seq" sequence } - { "quot" { $quotation "( elt -- ? )" } } + { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or " { $link f } } { "elt" "the first matching element, or " { $link f } } } { $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ; HELP: find-last -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ; HELP: find-last-from -{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } +{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ; HELP: map-find -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } } { $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ; HELP: any? -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } } { $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ; HELP: all? -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } } { $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ; HELP: push-if -{ $values { "elt" object } { "quot" { $quotation "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } } +{ $values { "elt" object } { "quot" { $quotation "( ..a elt -- ..b ? )" } } { "accum" "a resizable mutable sequence" } } { $description "Adds the element at the end of the sequence if the quotation yields a true value." } { $notes "This word is a factor of " { $link filter } "." } ; HELP: filter -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "subseq" "a new sequence" } } { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ; HELP: filter-as -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } } +{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } } { $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ; HELP: filter! -{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } } +{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( ... elt -- ... ? )" } } } { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." } { $side-effects "seq" } ; HELP: interleave -{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } } +{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( ... elt -- ... )" } } } { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." } { $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; @@ -622,7 +622,7 @@ HELP: reverse! { $side-effects "seq" } ; HELP: padding -{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( ... seq1 seq2 -- ... newseq )" } } { "newseq" "a new sequence" } } { $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ; HELP: pad-head @@ -961,7 +961,7 @@ HELP: supremum { $errors "Throws an error if the sequence is empty." } ; HELP: produce -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "seq" "a sequence" } } +{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "seq" "a sequence" } } { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." } { $examples "The following example divides a number by two until we reach zero, and accumulates intermediate results:" @@ -971,7 +971,7 @@ HELP: produce } ; HELP: produce-as -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "exemplar" sequence } { "seq" "a sequence" } } +{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "exemplar" sequence } { "seq" "a sequence" } } { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." } { $examples "See " { $link produce } " for examples." } ; @@ -995,8 +995,8 @@ HELP: count HELP: selector { $values - { "quot" { $quotation "( elt -- ? )" } } - { "selector" { $quotation "( elt -- )" } } { "accum" vector } } + { "quot" { $quotation "( ... elt -- ... ? )" } } + { "selector" { $quotation "( ... elt -- ... )" } } { "accum" vector } } { $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." } { $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;" "10 iota [ even? ] selector [ each ] dip ." @@ -1140,7 +1140,7 @@ HELP: set-fourth HELP: replicate { $values - { "len" integer } { "quot" { $quotation "( -- elt )" } } + { "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } } { "newseq" sequence } } { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." } { $examples @@ -1152,7 +1152,7 @@ HELP: replicate HELP: replicate-as { $values - { "len" integer } { "quot" { $quotation "( -- elt )" } } { "exemplar" sequence } + { "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } } { "exemplar" sequence } { "newseq" sequence } } { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." } { $examples @@ -1190,7 +1190,7 @@ HELP: virtual@ HELP: 2map-reduce { $values - { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( elt1 elt2 -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- result )" } } + { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( ..a elt1 elt2 -- ..b intermediate )" } } { "reduce-quot" { $quotation "( ..b prev intermediate -- ..a next )" } } { "result" object } } { $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." } { $errors "Throws an error if the sequence is empty." } @@ -1236,7 +1236,7 @@ HELP: collector HELP: binary-reduce { $values - { "seq" sequence } { "start" integer } { "quot" { $quotation "( elt1 elt2 -- newelt )" } } + { "seq" sequence } { "start" integer } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "value" object } } { $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." } { $examples "Computing factorial:" @@ -1247,7 +1247,7 @@ HELP: binary-reduce HELP: follow { $values - { "obj" object } { "quot" { $quotation "( prev -- result/f )" } } + { "obj" object } { "quot" { $quotation "( ... prev -- ... result/f )" } } { "seq" sequence } } { $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." } { $examples "Get random numbers until zero is reached:" @@ -1365,11 +1365,11 @@ HELP: assert-sequence= } ; HELP: cartesian-each -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } } { $description "Applies the quotation to every possible pairing of elements from the two sequences." } ; HELP: cartesian-map -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- result )" } } { "newseq" "a new sequence of sequences" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence of sequences" } } { $description "Applies the quotation to every possible pairing of elements from the two sequences, collecting results into a new sequence of sequences." } ; HELP: cartesian-product diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3e0f102181..02c5d0ac72 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -417,19 +417,19 @@ PRIVATE> : map-integers ( len quot exemplar -- newseq ) [ over ] dip [ [ collect ] keep ] new-like ; inline -: map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq ) +: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq ) [ (each) ] dip map-integers ; inline -: map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq ) +: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq ) over map-as ; inline -: replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq ) +: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq ) [ [ drop ] prepose ] dip map-integers ; inline -: replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq ) +: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq ) { } replicate-as ; inline -: map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq ) +: map! ( ... seq quot: ( ... elt -- ... newelt ) -- ... seq ) over [ map-into ] keep ; inline : accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq ) @@ -441,31 +441,31 @@ PRIVATE> : accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq ) (accumulate) map! ; inline -: 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... ) +: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... ) (2each) each-integer ; inline -: 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... ) +: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... ) [ [ ] bi@ ] dip 2each ; inline : 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result ) [ -rot ] dip 2each ; inline -: 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq ) +: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq ) [ (2each) ] dip map-integers ; inline -: 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq ) +: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq ) pick 2map-as ; inline : 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? ) (2each) all-integers? ; inline -: 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... ) +: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... ) (3each) each-integer ; inline -: 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq ) +: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq ) [ (3each) ] dip map-integers ; inline -: 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq ) +: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq ) [ pick ] dip swap 3map-as ; inline : find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ) @@ -522,7 +522,7 @@ PRIVATE> : follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq ) [ dup ] swap [ keep ] curry produce nip ; inline -: each-index ( ... seq quot: ( ... x i -- ... ) -- ... ) +: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... ) (each-index) each-integer ; inline : interleave ( seq between quot -- ) @@ -532,10 +532,10 @@ PRIVATE> 3bi ] if ; inline -: map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq ) +: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq ) [ dup length iota ] dip 2map ; inline -: reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result ) +: reduce-index ( ... seq identity quot: ( ... prev elt index -- ... next ) -- ... result ) swapd each-index ; inline : index ( obj seq -- n ) @@ -877,7 +877,7 @@ PRIVATE> [ [ unclip-slice ] dip [ call ] keep ] dip compose reduce ; inline -: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result ) +: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result ) [ [ prepare-2map-reduce ] keep ] dip compose compose each-integer ; inline @@ -889,10 +889,10 @@ PRIVATE> PRIVATE> -: map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt ) +: map-find ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt ) [ find ] (map-find) ; inline -: map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt ) +: map-find-last ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt ) [ find-last ] (map-find) ; inline : unclip-last-slice ( seq -- butlast-slice last ) From 18f3df9d4a6611e19c030c8c4e81c54c6371609b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 21:02:43 -0800 Subject: [PATCH 51/52] more help-lint --- .../mailboxes/mailboxes-docs.factor | 2 +- basis/documents/documents-docs.factor | 2 +- basis/lists/lists-docs.factor | 8 +++---- basis/lists/lists.factor | 4 ++-- core/alien/alien-docs.factor | 6 ++--- core/alien/alien.factor | 6 ++--- core/classes/tuple/tuple-docs.factor | 6 ++--- core/combinators/combinators-docs.factor | 2 +- core/continuations/continuations-docs.factor | 2 +- core/kernel/kernel-docs.factor | 22 +++++++++---------- core/kernel/kernel.factor | 2 +- core/lexer/lexer-docs.factor | 4 ++-- core/math/math-docs.factor | 8 +++---- extra/gpu/buffers/buffers-docs.factor | 2 +- 14 files changed, 38 insertions(+), 38 deletions(-) diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index 727efd45d0..461650738e 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -21,7 +21,7 @@ HELP: block-unless-pred { $values { "mailbox" mailbox } { "timeout" "a " { $link duration } " or " { $link f } } - { "pred" { $quotation "( obj -- ? )" } } + { "pred" { $quotation "( ... message -- ... ? )" } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index a4e02009df..203a6e3b09 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -42,7 +42,7 @@ HELP: doc-lines { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; HELP: each-line -{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } } +{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( ... line -- ... )" } } } { $description "Applies the quotation to each line in the range." } { $notes "The range is created by calling " { $link } "." } { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 53fde94687..a3056b0332 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -127,19 +127,19 @@ HELP: unswons { leach foldl lmap>array } related-words HELP: leach -{ $values { "list" list } { "quot" { $quotation "( obj -- )" } } } +{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... )" } } } { $description "Call the quotation for each item in the list." } ; HELP: foldl -{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ; HELP: foldr -{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ; HELP: lmap -{ $values { "list" list } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } +{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; HELP: lreverse diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index bef9261468..1e009df25c 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -61,10 +61,10 @@ PRIVATE> : lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result ) over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive -: foldl ( ... list identity quot: ( ... obj1 obj2 -- ... obj ) -- ... result ) +: foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result ) swapd leach ; inline -:: foldr ( ... list identity quot: ( ... obj1 obj2 -- ... obj ) -- ... result ) +:: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result ) list nil? [ identity ] [ list cdr identity quot foldr list car quot call diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 99f3a2b0f4..5f91d4c695 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -71,7 +71,7 @@ HELP: alien-invoke-error } ; HELP: alien-invoke -{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } } +{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } { "return..." "the return value of the function, if not " { $link void } } } { $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } { $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ; @@ -85,7 +85,7 @@ HELP: alien-indirect-error } ; HELP: alien-indirect -{ $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } +{ $values { "args..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "return..." "the return value of the function, if not " { $link void } } } { $description "Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } @@ -128,7 +128,7 @@ HELP: alien-assembly-error } ; HELP: alien-assembly -{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } } +{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "return..." "the return value of the function, if not " { $link void } } } { $description "Invokes arbitrary machine code, generated at compile-time by the quotation. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 3802147838..631fdcfc93 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -70,17 +70,17 @@ ERROR: alien-callback-error ; ERROR: alien-indirect-error ; -: alien-indirect ( ... funcptr return parameters abi -- ... ) +: alien-indirect ( args... funcptr return parameters abi -- return... ) alien-indirect-error ; ERROR: alien-invoke-error library symbol ; -: alien-invoke ( ... return library function parameters -- ... ) +: alien-invoke ( args... return library function parameters -- return... ) 2over alien-invoke-error ; ERROR: alien-assembly-error code ; -: alien-assembly ( ... return parameters abi quot -- ... ) +: alien-assembly ( args... return parameters abi quot -- return... ) dup alien-assembly-error ; ! Callbacks are registered in a global hashtable. Note that they diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 7f6078e321..b3bdcb4673 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -421,8 +421,8 @@ HELP: ( layout -- tuple ) { $values { "layout" "a tuple layout array" } { "tuple" tuple } } { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ; -HELP: ( ... layout -- tuple ) -{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } } +HELP: ( slots... layout -- tuple ) +{ $values { "slots..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } } { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ; HELP: new @@ -439,7 +439,7 @@ HELP: new } ; HELP: boa -{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } +{ $values { "slots..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } { $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." } { $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 31183a629e..5b1ce8e80c 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -295,7 +295,7 @@ HELP: spread { bi* tri* spread } related-words HELP: to-fixed-point -{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } } +{ $values { "object" object } { "quot" { $quotation "( ... object(n) -- ... object(n+1) )" } } { "object(n)" object } } { $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." } { $examples { $example diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 766a78c483..3710680269 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -182,7 +182,7 @@ HELP: cleanup { $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ; HELP: recover -{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } } +{ $values { "try" { $quotation "( ..a -- ..b )" } } { "recovery" { $quotation "( ..a error -- ..b )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; HELP: ignore-errors diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8b9650fc31..8512700852 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -169,7 +169,7 @@ HELP: xor { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ; HELP: both? -{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" } @@ -177,7 +177,7 @@ HELP: both? } ; HELP: either? -{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" } @@ -214,22 +214,22 @@ HELP: call-clear ( quot -- * ) { $notes "Used to implement " { $link "threads" } "." } ; HELP: keep -{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } } +{ $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } { $examples { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" } } ; HELP: 2keep -{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( ..a x y -- ..b )" } } } { $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ; HELP: 3keep -{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } } +{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( ..a x y z -- ..b )" } } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; HELP: bi -{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } } +{ $values { "x" object } { "p" { $quotation "( ..a x -- ..b )" } } { "q" { $quotation "( ..c x -- ..d )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." } { $examples "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:" @@ -595,7 +595,7 @@ $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: if* -{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } } { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." @@ -618,7 +618,7 @@ HELP: unless* { $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; HELP: ?if -{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } } +{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( ..a cond -- ..b )" } } { "false" { $quotation "( ..a default -- ..b )" } } } { $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." } { $notes "The following two lines are equivalent:" @@ -771,15 +771,15 @@ HELP: 4dip } ; HELP: while -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } +{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; HELP: until -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } +{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ; HELP: do -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } +{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } } { $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ; HELP: loop diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 3a53eb91e2..e506b7fc27 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -226,7 +226,7 @@ M: callstack clone (clone) ; inline ! Tuple construction GENERIC: new ( class -- tuple ) -GENERIC: boa ( ... class -- tuple ) +GENERIC: boa ( slots... class -- tuple ) ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index 04985a4340..3dc534cdfd 100644 --- a/core/lexer/lexer-docs.factor +++ b/core/lexer/lexer-docs.factor @@ -67,13 +67,13 @@ HELP: still-parsing? { $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; HELP: each-token -{ $values { "end" string } { "quot" { $quotation "( token -- )" } } } +{ $values { "end" string } { "quot" { $quotation "( ... token -- ... )" } } } { $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." } { $examples "This word is used to implement " { $link POSTPONE: USING: } "." } $parsing-note ; HELP: map-tokens -{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } } +{ $values { "end" string } { "quot" { $quotation "( ... token -- ... elt )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } } { $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." } $parsing-note ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 50a31434f4..1de443b0c5 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -410,22 +410,22 @@ HELP: power-of-2? { $description "Tests if " { $snippet "n" } " is a power of 2." } ; HELP: each-integer -{ $values { "n" integer } { "quot" { $quotation "( i -- )" } } } +{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... )" } } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." } { $notes "This word is used to implement " { $link each } "." } ; HELP: all-integers? -{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } } +{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "?" "a boolean" } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." } { $notes "This word is used to implement " { $link all? } "." } ; HELP: find-integer -{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } } +{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." } { $notes "This word is used to implement " { $link find } "." } ; HELP: find-last-integer -{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } } +{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } } { $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." } { $notes "This word is used to implement " { $link find-last } "." } ; diff --git a/extra/gpu/buffers/buffers-docs.factor b/extra/gpu/buffers/buffers-docs.factor index 9ca1093000..cb1031c7fa 100644 --- a/extra/gpu/buffers/buffers-docs.factor +++ b/extra/gpu/buffers/buffers-docs.factor @@ -203,7 +203,7 @@ HELP: vertex-buffer HELP: with-mapped-buffer { $values - { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( alien -- )" } } + { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( ..a alien -- ..b )" } } } { $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ; From 6bf709429b1042aff2f8d5016f0dce1bbe69ced2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 9 Mar 2010 22:38:41 -0800 Subject: [PATCH 52/52] fix effect of primitive --- core/bootstrap/primitives.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 43aeb6bd70..2772b68875 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -420,7 +420,7 @@ tuple { "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) } { "" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) } { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) } - { "" "classes.tuple.private" "primitive_tuple_boa" (( ... layout -- tuple )) } + { "" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) } { "" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) } { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) } { "lookup-method" "generic.single.private" "primitive_lookup_method" (( object methods -- method )) }