From 66f5694462f15a4a2d5641fa04b6768cb4888a43 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 17 Jan 2009 22:15:57 -0600 Subject: [PATCH 1/9] document more core/ words --- core/assocs/assocs-docs.factor | 7 ++++ core/byte-arrays/byte-arrays-docs.factor | 4 +++ core/math/math-docs.factor | 6 +++- core/sequences/sequences-docs.factor | 46 ++++++++++++++++++++++-- 4 files changed, 60 insertions(+), 3 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 2f486cd948..627d4aeb80 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -115,6 +115,7 @@ $nl { $subsection assoc-map } { $subsection assoc-push-if } { $subsection assoc-filter } +{ $subsection assoc-filter-as } { $subsection assoc-contains? } { $subsection assoc-all? } "Additional combinators:" @@ -232,6 +233,12 @@ HELP: assoc-filter { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; +HELP: assoc-filter-as +{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } } +{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ; + +{ assoc-filter assoc-filter-as } related-words + HELP: assoc-contains? { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } } { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 25bff0fce5..f1d94a46f7 100644 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -30,6 +30,10 @@ HELP: ( n -- byte-array ) { $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } } { $description "Creates a new byte array holding " { $snippet "n" } " bytes." } ; +HELP: (byte-array) +{ $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } } +{ $description "Creates a new byte array with unspecified contents of length " { $snippet "n" } " bytes." } ; + HELP: >byte-array { $values { "seq" "a sequence" } { "byte-array" byte-array } } { $description diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 2f7ab75103..348d27ba0f 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel sequences quotations -math.private ; +math.private byte-arrays io.binary ; IN: math HELP: number= @@ -306,6 +306,10 @@ HELP: find-last-integer { $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 } "." } ; +HELP: byte-array>bignum +{ $values { "byte-array" byte-array } { "n" integer } } +{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ; + ARTICLE: "division-by-zero" "Division by zero" "Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value." $nl diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0b9dbcdfa7..1aeed75470 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -679,12 +679,28 @@ HELP: append } } ; +HELP: append-as +{ $values { "seq1" sequence } { "seq2" sequence } { "exemplar" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence of the same type as " { $snippet "exemplar" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." } +{ $errors "Throws an error if " { $snippet "seq1" } " or " { $snippet "seq2" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } +{ $examples + { $example "USING: prettyprint sequences ;" + "{ 1 2 } B{ 3 4 } B{ } append-as ." + "B{ 1 2 3 4 }" + } + { $example "USING: prettyprint sequences strings ;" + "\"go\" \"ing\" SBUF\" \" append-as ." + "SBUF\" going\"" + } +} ; + +{ append append-as } related-words + HELP: prepend { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } } { $description "Outputs a new sequence of the same type as " { $snippet "seq2" } " consisting of the elements of " { $snippet "seq2" } " followed by " { $snippet "seq1" } "." } { $errors "Throws an error if " { $snippet "seq1" } " contains elements not permitted in sequences of the same class as " { $snippet "seq2" } "." } -{ $examples - { $example "USING: prettyprint sequences ;" +{ $examples { $example "USING: prettyprint sequences ;" "{ 1 2 } B{ 3 4 } prepend ." "B{ 3 4 1 2 }" } @@ -705,6 +721,19 @@ HELP: 3append } } ; +HELP: 3append-as +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "exemplar" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence consisting of the elements of " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } " in turn of the same type as " { $snippet "exemplar" } "." } +{ $errors "Throws an error if " { $snippet "seq1" } ", " { $snippet "seq2" } ", or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } +{ $examples + { $example "USING: prettyprint sequences ;" + "\"a\" \"b\" \"c\" SBUF\" \" 3append-as ." + "SBUF\" abc\"" + } +} ; + +{ 3append 3append-as } related-words + HELP: surround { $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } } { $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." } @@ -891,6 +920,16 @@ HELP: produce { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" } } ; +HELP: produce-as +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "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 + "The following example divides a number by two until we reach zero, and accumulates intermediate results:" + { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] V{ } produce-as nip ." "V{ 668 334 167 83 41 20 10 5 2 1 0 }" } + "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:" + { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] B{ } produce-as ." "B{ 8 2 2 9 }" } +} ; + HELP: sigma { $values { "seq" sequence } { "quot" quotation } { "n" number } } { $description "Like map sum, but without creating an intermediate sequence." } @@ -1359,8 +1398,10 @@ ARTICLE: "sequences-reshape" "Reshaping sequences" ARTICLE: "sequences-appending" "Appending sequences" { $subsection append } +{ $subsection append-as } { $subsection prepend } { $subsection 3append } +{ $subsection 3append-as } { $subsection surround } { $subsection glue } { $subsection concat } @@ -1417,6 +1458,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection map-index } { $subsection accumulate } { $subsection produce } +{ $subsection produce-as } "Filtering:" { $subsection push-if } { $subsection filter } From df7ad34db205028bf3b29b943f4cce02ea849ca6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 18 Jan 2009 17:28:36 -0600 Subject: [PATCH 2/9] Credit where credit is due --- basis/unix/authors.txt | 1 + basis/unix/unix.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/basis/unix/authors.txt b/basis/unix/authors.txt index 1901f27a24..e1907c6d91 100644 --- a/basis/unix/authors.txt +++ b/basis/unix/authors.txt @@ -1 +1,2 @@ Slava Pestov +Eduardo Cavazos diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 52e7473800..c2b5ad4ea4 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -1,4 +1,5 @@ ! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2008 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces From 213a429928cdd0daeec62b2cf8d3179656da0978 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 18 Jan 2009 20:26:58 -0600 Subject: [PATCH 3/9] add nappend and nappend-as, unit tests, and some docs for them --- .../generalizations-docs.factor | 52 +++++++++++++++++++ .../generalizations-tests.factor | 9 ++++ basis/generalizations/generalizations.factor | 8 ++- 3 files changed, 68 insertions(+), 1 deletion(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 9fde1fd1b1..a676be3be8 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -259,6 +259,55 @@ HELP: mnswap } } ; +HELP: n*quot +{ $values + { "n" integer } { "seq" sequence } + { "seq'" sequence } +} +{ $examples + { $example "USING: generalizations prettyprint math ;" + "3 [ + ] n*quot ." + "[ + + + ]" + } +} +{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ; + +HELP: nappend +{ $values + { "n" integer } + { "seq" sequence } +} +{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." } +{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." } +{ $examples + { $example "USING: generalizations prettyprint math ;" + "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ." + "{ 1 2 3 4 5 6 7 8 }" + } +} ; + +HELP: nappend-as +{ $values + { "n" integer } { "exemplar" sequence } + { "seq" sequence } +} +{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." } +{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." } +{ $examples + { $example "USING: generalizations prettyprint math ;" + "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ." + "V{ 1 2 3 4 5 6 7 8 }" + } +} ; + +{ nappend nappend-as } related-words + +HELP: ntuck +{ $values + { "n" integer } +} +{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; + ARTICLE: "generalizations" "Generalized shuffle words and combinators" "The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " "macros where the arity of the input quotations depends on an " @@ -268,6 +317,8 @@ $nl { $subsection narray } { $subsection nsequence } { $subsection firstn } +{ $subsection nappend } +{ $subsection nappend-as } "Generated stack shuffle operations:" { $subsection ndup } { $subsection npick } @@ -275,6 +326,7 @@ $nl { $subsection -nrot } { $subsection nnip } { $subsection ndrop } +{ $subsection ntuck } { $subsection nrev } { $subsection mnswap } "Generalized combinators:" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 4eb4c4e686..35e02f08b4 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -5,6 +5,7 @@ IN: generalizations.tests { 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test { 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test { 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test + [ 1 1 ndup ] must-infer { 1 1 } [ 1 1 ndup ] unit-test { 1 2 1 2 } [ 1 2 2 ndup ] unit-test @@ -22,6 +23,8 @@ IN: generalizations.tests { 4 } [ 1 2 3 4 3 nnip ] unit-test [ 1 2 3 4 4 ndrop ] must-infer { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test +[ [ 1 ] 5 ndip ] must-infer +[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test [ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test @@ -44,3 +47,9 @@ IN: generalizations.tests [ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test [ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test + +[ { 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test +[ V{ 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test + +[ 4 nappend ] must-infer +[ 4 { } nappend-as ] must-infer diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index a447d5c706..b3b4c9b11c 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -2,7 +2,8 @@ ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math math.ranges -combinators macros quotations fry ; +combinators macros quotations fry macros locals datastack +multiline ; IN: generalizations << @@ -78,3 +79,8 @@ MACRO: napply ( quot n -- ) MACRO: mnswap ( m n -- ) 1+ '[ _ -nrot ] spread>quot ; + +: nappend-as ( n exemplar -- seq ) + [ narray concat ] dip like ; inline + +: nappend ( n -- seq ) narray concat ; inline From befeff625d2036be72d8d9a3b891925d0fd7b549 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 19 Jan 2009 03:39:53 +0100 Subject: [PATCH 4/9] FUEL: Ignore paren chars in \, POSTPONE: and stack effects. --- misc/fuel/fuel-font-lock.el | 18 +++++++++++------- misc/fuel/fuel-syntax.el | 3 ++- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index fe20024fcd..4db9eee92c 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -84,6 +84,8 @@ (t 'default)))) ((char-equal (char-after (nth 8 state)) ?U) 'factor-font-lock-parsing-word) + ((char-equal (char-after (nth 8 state)) ?\() + 'factor-font-lock-stack-effect) (t 'factor-font-lock-comment))) (defconst fuel-font-lock--font-lock-keywords @@ -135,16 +137,18 @@ ;;; Fontify strings as Factor code: -(defvar fuel-font-lock--font-lock-buffer - (let ((buffer (get-buffer-create " *fuel font lock*"))) - (set-buffer buffer) - (set-syntax-table fuel-syntax--syntax-table) - (fuel-font-lock--font-lock-setup) - buffer)) +(defun fuel-font-lock--font-lock-buffer () + (let ((name " *fuel font lock*")) + (or (get-buffer name) + (let ((buffer (get-buffer-create name))) + (set-buffer buffer) + (set-syntax-table fuel-syntax--syntax-table) + (fuel-font-lock--font-lock-setup) + buffer)))) (defun fuel-font-lock--factor-str (str) (save-current-buffer - (set-buffer fuel-font-lock--font-lock-buffer) + (set-buffer (fuel-font-lock--font-lock-buffer)) (erase-buffer) (insert str) (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 8d2948af58..82df3e07d8 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -240,10 +240,11 @@ (defconst fuel-syntax--syntactic-keywords `(;; CHARs: - ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) + ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w")) ;; Comments: ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "b")) ;; Strings ("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\"")) ("\\_<<\\(\"\\)\\_>" (1 "\"")) From 8c857f0d4b9ffdd3f073fb0d0a707cc26323063d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 18 Jan 2009 20:40:19 -0600 Subject: [PATCH 5/9] redo pack/unpack, refactor most of pack to be more efficient. sorry if i killed a word you were using. --- basis/pack/pack-tests.factor | 19 ++-- basis/pack/pack.factor | 190 ++++++++++++++--------------------- 2 files changed, 83 insertions(+), 126 deletions(-) diff --git a/basis/pack/pack-tests.factor b/basis/pack/pack-tests.factor index 1be37292a0..999a952174 100755 --- a/basis/pack/pack-tests.factor +++ b/basis/pack/pack-tests.factor @@ -1,5 +1,6 @@ USING: io io.streams.string kernel namespaces make -pack strings tools.test ; +pack strings tools.test pack.private ; +IN: pack.tests [ B{ 1 0 2 0 0 3 0 0 0 4 0 0 0 0 0 0 0 5 } ] [ { 1 2 3 4 5 } @@ -37,15 +38,6 @@ pack strings tools.test ; "cstiq" [ pack-native ] keep unpack-native ] unit-test -[ 2 ] [ - [ 2 "int" b, ] B{ } make - [ "int" read-native ] with-input-stream -] unit-test - -[ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test -[ f ] [ "" [ read-c-string ] with-string-reader ] unit-test -[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test - [ 9 ] [ "iic" packed-length ] unit-test [ "iii" read-packed-le ] must-infer [ "iii" read-packed-be ] must-infer @@ -53,3 +45,10 @@ pack strings tools.test ; [ "iii" unpack-le ] must-infer [ "iii" unpack-be ] must-infer [ "iii" unpack-native ] must-infer +[ "iii" pack ] must-infer +[ "iii" unpack ] must-infer + +: test-pack ( str -- ba ) + "iii" pack ; + +[ test-pack ] must-infer diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 136deb9ff5..aec4414c71 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -3,7 +3,9 @@ USING: alien alien.c-types arrays assocs byte-arrays io io.binary io.streams.string kernel math math.parser namespaces make parser prettyprint quotations sequences strings vectors -words macros math.functions math.bitwise fry ; +words macros math.functions math.bitwise fry generalizations +combinators.smart io.streams.byte-array io.encodings.binary +math.vectors combinators multiline ; IN: pack SYMBOL: big-endian @@ -18,131 +20,77 @@ SYMBOL: big-endian PRIVATE> -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; inline - -: endian> ( obj -- str ) - big-endian get [ be> ] [ le> ] if ; inline - -GENERIC: b, ( n obj -- ) -M: integer b, ( m n -- ) >endian % ; - -! for doing native, platform-dependent sized values -M: string b, ( n string -- ) heap-size b, ; -: read-native ( string -- n ) heap-size read endian> ; - -! Portable -: s8, ( n -- ) 1 b, ; -: u8, ( n -- ) 1 b, ; -: s16, ( n -- ) 2 b, ; -: u16, ( n -- ) 2 b, ; -: s24, ( n -- ) 3 b, ; -: u24, ( n -- ) 3 b, ; -: s32, ( n -- ) 4 b, ; -: u32, ( n -- ) 4 b, ; -: s64, ( n -- ) 8 b, ; -: u64, ( n -- ) 8 b, ; -: s128, ( n -- ) 16 b, ; -: u128, ( n -- ) 16 b, ; -: float, ( n -- ) float>bits 4 b, ; -: double, ( n -- ) double>bits 8 b, ; -: c-string, ( str -- ) % 0 u8, ; - -128-ber) ( n -- ) - dup 0 > [ - [ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift - (>128-ber) - ] [ - drop - ] if ; - -PRIVATE> - -: >128-ber ( n -- str ) - [ - [ HEX: 7f bitand , ] keep -7 shift - (>128-ber) - ] { } make reverse ; - : >signed ( x n -- y ) 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; -: read-signed ( n -- str ) - dup read endian> swap 8 * >signed ; +: >endian ( obj n -- str ) + big-endian get [ >be ] [ >le ] if ; inline -: read-unsigned ( n -- m ) read endian> ; +: unsigned-endian> ( obj -- str ) + big-endian get [ be> ] [ le> ] if ; inline -: read-s8 ( -- n ) 1 read-signed ; -: read-u8 ( -- n ) 1 read-unsigned ; -: read-s16 ( -- n ) 2 read-signed ; -: read-u16 ( -- n ) 2 read-unsigned ; -: read-s24 ( -- n ) 3 read-signed ; -: read-u24 ( -- n ) 3 read-unsigned ; -: read-s32 ( -- n ) 4 read-signed ; -: read-u32 ( -- n ) 4 read-unsigned ; -: read-s64 ( -- n ) 8 read-signed ; -: read-u64 ( -- n ) 8 read-unsigned ; -: read-s128 ( -- n ) 16 read-signed ; -: read-u128 ( -- n ) 16 read-unsigned ; +: signed-endian> ( obj n -- str ) + [ unsigned-endian> ] dip >signed ; -: read-float ( -- n ) - 4 read endian> bits>float ; +GENERIC: >n-byte-array ( obj n -- byte-array ) -: read-double ( -- n ) - 8 read endian> bits>double ; +M: integer >n-byte-array ( m n -- byte-array ) >endian ; -: read-c-string ( -- str/f ) - "\0" read-until swap and ; +! for doing native, platform-dependent sized values +M: string >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ; -: read-c-string* ( n -- str/f ) - read [ zero? ] trim-right [ f ] when-empty ; - -: (read-128-ber) ( n -- n ) - read1 - [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep - 7 bit? [ (read-128-ber) ] when ; - -: read-128-ber ( -- n ) - 0 (read-128-ber) ; +: s8>byte-array ( n -- byte-array ) 1 >n-byte-array ; +: u8>byte-array ( n -- byte-array ) 1 >n-byte-array ; +: s16>byte-array ( n -- byte-array ) 2 >n-byte-array ; +: u16>byte-array ( n -- byte-array ) 2 >n-byte-array ; +: s24>byte-array ( n -- byte-array ) 3 >n-byte-array ; +: u24>byte-array ( n -- byte-array ) 3 >n-byte-array ; +: s32>byte-array ( n -- byte-array ) 4 >n-byte-array ; +: u32>byte-array ( n -- byte-array ) 4 >n-byte-array ; +: s64>byte-array ( n -- byte-array ) 8 >n-byte-array ; +: u64>byte-array ( n -- byte-array ) 8 >n-byte-array ; +: s128>byte-array ( n -- byte-array ) 16 >n-byte-array ; +: u128>byte-array ( n -- byte-array ) 16 >n-byte-array ; +: write-float ( n -- byte-array ) float>bits 4 >n-byte-array ; +: write-double ( n -- byte-array ) double>bits 8 >n-byte-array ; +: write-c-string ( byte-array -- byte-array ) { 0 } B{ } append-as ; byte-array } + { CHAR: C u8>byte-array } + { CHAR: s s16>byte-array } + { CHAR: S u16>byte-array } + { CHAR: t s24>byte-array } + { CHAR: T u24>byte-array } + { CHAR: i s32>byte-array } + { CHAR: I u32>byte-array } + { CHAR: q s64>byte-array } + { CHAR: Q u64>byte-array } + { CHAR: f write-float } + { CHAR: F write-float } + { CHAR: d write-double } + { CHAR: D write-double } } CONSTANT: unpack-table H{ - { CHAR: c read-s8 } - { CHAR: C read-u8 } - { CHAR: s read-s16 } - { CHAR: S read-u16 } - { CHAR: t read-s24 } - { CHAR: T read-u24 } - { CHAR: i read-s32 } - { CHAR: I read-u32 } - { CHAR: q read-s64 } - { CHAR: Q read-u64 } - { CHAR: f read-float } - { CHAR: F read-float } - { CHAR: d read-double } - { CHAR: D read-double } + { CHAR: c [ 8 signed-endian> ] } + { CHAR: C [ unsigned-endian> ] } + { CHAR: s [ 16 signed-endian> ] } + { CHAR: S [ unsigned-endian> ] } + { CHAR: t [ 24 signed-endian> ] } + { CHAR: T [ unsigned-endian> ] } + { CHAR: i [ 32 signed-endian> ] } + { CHAR: I [ unsigned-endian> ] } + { CHAR: q [ 64 signed-endian> ] } + { CHAR: Q [ unsigned-endian> ] } + { CHAR: f [ unsigned-endian> bits>float ] } + { CHAR: F [ unsigned-endian> bits>float ] } + { CHAR: d [ unsigned-endian> bits>double ] } + { CHAR: D [ unsigned-endian> bits>double ] } } CONSTANT: packed-length-table @@ -163,11 +111,19 @@ CONSTANT: packed-length-table { CHAR: D 8 } } -MACRO: pack ( seq str -- quot ) - [ pack-table at 1quotation '[ _ @ ] ] [ ] 2map-as concat - '[ _ B{ } make ] ; +MACRO: pack ( str -- quot ) + [ pack-table at '[ _ execute ] ] { } map-as + '[ _ spread ] + '[ _ input + +: ch>packed-length ( ch -- n ) + packed-length-table at ; inline + +: packed-length ( str -- n ) + [ ch>packed-length ] sigma ; : pack-native ( seq str -- seq ) [ set-big-endian pack ] with-scope ; inline @@ -180,9 +136,14 @@ PRIVATE> packed-length ] { } map-as start/end ] + [ [ unpack-table at '[ @ ] ] { } map-as ] bi + [ '[ [ _ _ ] dip @ ] ] 3map + '[ _ cleave ] '[ _ output>array ] ; PRIVATE> @@ -195,9 +156,6 @@ PRIVATE> : unpack-le ( seq str -- seq ) [ big-endian off unpack ] with-scope ; inline -: packed-length ( str -- n ) - [ packed-length-table at ] sigma ; - ERROR: packed-read-fail str bytes ; Date: Mon, 19 Jan 2009 04:18:20 +0100 Subject: [PATCH 6/9] FUEL: Better font lock for <" "> forms. --- misc/fuel/fuel-font-lock.el | 28 ++++++++++++++-------------- misc/fuel/fuel-syntax.el | 4 ++-- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 4db9eee92c..5b4ae09f25 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -73,20 +73,20 @@ ;;; Font lock: (defun fuel-font-lock--syntactic-face (state) - (cond ((nth 3 state) 'factor-font-lock-string) - ((char-equal (char-after (nth 8 state)) ?\ ) - (save-excursion - (goto-char (nth 8 state)) - (beginning-of-line) - (cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name) - ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ") - 'factor-font-lock-symbol) - (t 'default)))) - ((char-equal (char-after (nth 8 state)) ?U) - 'factor-font-lock-parsing-word) - ((char-equal (char-after (nth 8 state)) ?\() - 'factor-font-lock-stack-effect) - (t 'factor-font-lock-comment))) + (if (nth 3 state) 'factor-font-lock-string + (let ((c (char-after (nth 8 state)))) + (cond ((char-equal c ?\ ) + (save-excursion + (goto-char (nth 8 state)) + (beginning-of-line) + (cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name) + ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ") + 'factor-font-lock-symbol) + (t 'default)))) + ((char-equal c ?U) 'factor-font-lock-parsing-word) + ((char-equal c ?\() 'factor-font-lock-stack-effect) + ((char-equal c ?\") 'factor-font-lock-string) + (t 'factor-font-lock-comment))))) (defconst fuel-font-lock--font-lock-keywords `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 82df3e07d8..880a8eca65 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -247,8 +247,8 @@ ("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "b")) ;; Strings ("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\"")) - ("\\_<<\\(\"\\)\\_>" (1 "\"")) - ("\\_<\\(\"\\)>\\_>" (1 "\"")) + ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) ;; Multiline constructs ("\\_<\\(U\\)SING: \\(;\\)" (1 "b")) ("\\_ Date: Sun, 18 Jan 2009 21:18:52 -0600 Subject: [PATCH 7/9] Add append-outputs and append-outputs-as, docs, tests --- basis/combinators/smart/smart-docs.factor | 36 +++++++++++++++++++++- basis/combinators/smart/smart-tests.factor | 22 +++++++++++-- basis/combinators/smart/smart.factor | 6 ++++ 3 files changed, 61 insertions(+), 3 deletions(-) diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 3df709c9fa..75f83c1a55 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -76,6 +76,37 @@ HELP: sum-outputs } } ; +HELP: append-outputs +{ $values + { "quot" quotation } + { "seq" sequence } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of the outputs appended." } +{ $examples + { $example + "USING: combinators.smart prettyprint ;" + "[ { 1 2 } { \"A\" \"b\" } ] append-outputs ." + "{ 1 2 \"A\" \"b\" }" + } +} ; + +HELP: append-outputs-as +{ $values + { "quot" quotation } { "exemplar" sequence } + { "seq" sequence } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of type " { $snippet "exemplar" } " of the outputs appended." } +{ $examples + { $example + "USING: combinators.smart prettyprint ;" + "[ { 1 2 } { \"A\" \"b\" } ] V{ } append-outputs-as ." + "V{ 1 2 \"A\" \"b\" }" + } +} ; + +{ append-outputs append-outputs-as } related-words + + ARTICLE: "combinators.smart" "Smart combinators" "The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl "Smart inputs from a sequence:" @@ -86,6 +117,9 @@ ARTICLE: "combinators.smart" "Smart combinators" "Reducing the output of a quotation:" { $subsection reduce-outputs } "Summing the output of a quotation:" -{ $subsection sum-outputs } ; +{ $subsection sum-outputs } +"Appending the results of a quotation:" +{ $subsection append-outputs } +{ $subsection append-outputs-as } ; ABOUT: "combinators.smart" diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 54c53477db..370dc26960 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -12,10 +12,28 @@ IN: combinators.smart.tests [ { 9 11 } [ + ] input> ] dip '[ @ _ _ nappend-as ] ; + +: append-outputs ( quot -- seq ) + { } append-outputs-as ; inline From 478fca5dc651786e440b1f7464cee672e3fda156 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 18 Jan 2009 21:23:33 -0600 Subject: [PATCH 8/9] Take your stinking paws off me, you damned dirty datastack vocabulary! --- basis/generalizations/generalizations.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index b3b4c9b11c..c6a17df099 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -2,8 +2,7 @@ ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math math.ranges -combinators macros quotations fry macros locals datastack -multiline ; +combinators macros quotations fry macros locals ; IN: generalizations << From e27daf5dafc45daa5c290b296aa1b3f52471658d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 19 Jan 2009 05:10:47 +0100 Subject: [PATCH 9/9] FUEL: New fuel-switch-to-buffer command family. --- misc/fuel/README | 3 +++ misc/fuel/fuel-edit.el | 26 ++++++++++++++++++++++++++ misc/fuel/fuel-mode.el | 3 +++ 3 files changed, 32 insertions(+) diff --git a/misc/fuel/README b/misc/fuel/README index 706191aaa3..562128dc29 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -74,6 +74,9 @@ beast. - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files + - C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer) + - C-x4s : switch to other factor buffer in other window + - C-x5s : switch to other factor buffer in other frame - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var) - M-, : go back to where M-. was last invoked diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index b0756826f1..0334ab6104 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -132,6 +132,32 @@ was last invoked." (pop-tag-mark) (error "No previous location for find word or vocab invokation"))) +(defvar fuel-edit--buffer-history nil) + +(defun fuel-switch-to-buffer (&optional method) + "Switch to any of the existing Factor buffers, with completion." + (interactive) + (let ((buffer (completing-read "Factor buffer: " + (remove (buffer-name) + (mapcar 'buffer-name (buffer-list))) + '(lambda (s) (string-match "\\.factor$" s)) + t + nil + fuel-edit--buffer-history))) + (cond ((eq method 'window) (switch-to-buffer-other-window buffer)) + ((eq method 'frame) (switch-to-buffer-other-frame buffer)) + (t (switch-to-buffer buffer))))) + +(defun fuel-switch-to-buffer-other-window () + "Switch to any of the existing Factor buffers, in other window." + (interactive) + (fuel-switch-to-buffer 'window)) + +(defun fuel-switch-to-buffer-other-frame () + "Switch to any of the existing Factor buffers, in other frame." + (interactive) + (fuel-switch-to-buffer 'frame)) + (provide 'fuel-edit) ;;; fuel-edit.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 9936d052fc..1165b17e60 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -177,6 +177,9 @@ interacting with a factor listener is at your disposal. (fuel-mode--key-1 ?l 'fuel-run-file) (fuel-mode--key-1 ?r 'fuel-eval-region) (fuel-mode--key-1 ?z 'run-factor) +(fuel-mode--key-1 ?s 'fuel-switch-to-buffer) +(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window) +(define-key fuel-mode-map "\C-x5s" 'fuel-switch-to-buffer-other-frame) (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) (define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)