steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

New locals syntax; added M::

db4
Slava Pestov 2008-02-26 18:40:32 -06:00
parent fe37c87d2f
commit 64469916a9
15 changed files with 156 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/parser/parser.factor
View File

@ -352,6 +352,8 @@ TUPLE: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
: (:) CREATE dup reset-generic parse-definition ;
GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ;

2
core/syntax/syntax.factor
View File

@ -107,7 +107,7 @@ IN: bootstrap.syntax
] define-syntax
":" [
CREATE dup reset-generic parse-definition define
(:) define
] define-syntax
"GENERIC:" [

6
extra/benchmark/fasta/fasta.factor
View File

@ -51,7 +51,7 @@ HINTS: random fixnum ;
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random | seed chars floats |
:: select-random ( seed chars floats -- elt )
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
@ -62,7 +62,7 @@ HINTS: random fixnum ;
: write-description ( desc id -- )
">" write write bl print ; inline
:: split-lines | n quot |
:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
dup zero? [ drop ] quot if ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta | k len alu |
:: make-repeat-fasta ( k len alu -- )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +

2
extra/channels/examples/examples.factor
View File

@ -24,7 +24,7 @@ IN: channels.examples
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
:: (sieve) | prime c | ( prime c -- )
:: (sieve) ( prime c -- )
[let | p [ c from ]
newc [ <channel> ] |
p prime to

1
extra/cocoa/plists/plists.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
xml.writer xml.utilities kernel namespaces ;
IN: cocoa.plists
GENERIC: >plist ( obj -- tag )

2
extra/concurrency/exchangers/exchangers-tests.factor
View File

@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel
threads ;
:: exchanger-test | |
:: exchanger-test ( -- )
[let |
ex [ <exchanger> ]
c [ 2 <count-down> ]

10
extra/concurrency/locks/locks-tests.factor
View File

@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar ;
:: lock-test-0 | |
:: lock-test-0 ( -- )
[let | v [ V{ } clone ]
c [ 2 <count-down> ] |
@ -27,7 +27,7 @@ threads sequences calendar ;
v
] ;
:: lock-test-1 | |
:: lock-test-1 ( -- )
[let | v [ V{ } clone ]
l [ <lock> ]
c [ 2 <count-down> ] |
@ -79,7 +79,7 @@ threads sequences calendar ;
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 | |
:: rw-lock-test-1 ( -- )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 1 <count-down> ]
@ -129,7 +129,7 @@ threads sequences calendar ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 | |
:: rw-lock-test-2 ( -- )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 2 <count-down> ]
@ -160,7 +160,7 @@ threads sequences calendar ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test | |
:: lock-timeout-test ( -- )
[let | l [ <lock> ] |
[
l [ 1 seconds sleep ] with-lock

2
extra/crypto/md5/md5.factor
View File

@ -32,7 +32,7 @@ SYMBOL: old-d
old-c c update-old-new
old-d d update-old-new ;
:: (ABCD) | x s i k func a b c d |
:: (ABCD) ( x s i k func a b c d -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [
b get c get d get func call w+

2
extra/io/sniffer/bsd/bsd.factor
View File

@ -24,7 +24,7 @@ C: <sniffer-spec> sniffer-spec
: IOC_INOUT IOC_IN IOC_OUT bitor ; inline
: IOC_DIRMASK HEX: e0000000 ; inline
:: ioc | inout group num len |
:: ioc ( inout group num len -- n )
group first 8 shift num bitor
len IOCPARM_MASK bitand 16 shift bitor
inout bitor ;

18
extra/locals/locals-docs.factor
View File

@ -16,7 +16,7 @@ HELP: [|
{ $examples
{ $example
"USE: locals"
":: adder | n | [| m | m n + ] ;"
":: adder ( n -- quot ) [| m | m n + ] ;"
"3 5 adder call ."
"8"
}
@ -29,7 +29,7 @@ HELP: [let
{ $examples
{ $example
"USING: locals math.functions ;"
":: frobnicate | n seq |"
":: frobnicate ( n seq -- newseq )"
" [let | n' [ n 6 * ] |"
" seq [ n' gcd nip ] map ] ;"
"6 { 36 14 } frobnicate ."
@ -44,7 +44,7 @@ HELP: [wlet
{ $examples
{ $example
"USE: locals"
":: quuxify | n seq |"
":: quuxify ( n seq -- newseq )"
" [wlet | add-n [| m | m n + ] |"
" seq [ add-n ] map ] ;"
"2 { 1 2 3 } quuxify ."
@ -57,13 +57,15 @@ HELP: with-locals
{ $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
HELP: ::
{ $syntax ":: word | bindings... | body... ;" }
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
HELP: MACRO::
{ $syntax "MACRO:: word | bindings... | body... ;" }
{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ;
{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals"
$nl
"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
{ $code
":: counter | |"
":: counter ( -- )"
" [let | value! [ 0 ] |"
" [ value 1+ dup value! ]"
" [ value 1- dup value! ] ] ;"
@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
$nl
"Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
{ $code
":: bad-cond-usage | a |"
":: bad-cond-usage ( a -- ... )"
" { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }"
" { [ a 0 = ] [ ... ] } ;"

86
extra/locals/locals-tests.factor
View File

@ -1,52 +1,52 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays ;
namespaces arrays strings prettyprint ;
IN: temporary
:: foo | a b | a a ;
:: foo ( a b -- a a ) a a ;
[ 1 1 ] [ 1 2 foo ] unit-test
:: add-test | a b | a b + ;
:: add-test ( a b -- c ) a b + ;
[ 3 ] [ 1 2 add-test ] unit-test
:: sub-test | a b | a b - ;
:: sub-test ( a b -- c ) a b - ;
[ -1 ] [ 1 2 sub-test ] unit-test
:: map-test | a b | a [ b + ] map ;
:: map-test ( a b -- seq ) a [ b + ] map ;
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ;
:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
:: let-test | c |
:: let-test ( c -- d )
[let | a [ 1 ] b [ 2 ] | a b + c + ] ;
[ 7 ] [ 4 let-test ] unit-test
:: let-test-2 | |
[let | a [ ] | [let | b [ a ] | a ] ] ;
:: let-test-2 ( a -- a )
a [let | a [ ] | [let | b [ a ] | a ] ] ;
[ 3 ] [ 3 let-test-2 ] unit-test
:: let-test-3 | |
[let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
:: let-test-3 ( a -- a )
a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
:: let-test-4 | |
[let | a [ 1 ] b [ ] | a b 2array ] ;
:: let-test-4 ( a -- b )
a [let | a [ 1 ] b [ ] | a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 | |
[let | a [ ] b [ ] | a b 2array ] ;
:: let-test-5 ( a -- b )
a [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 | |
[let | a [ ] b [ 1 ] | a b 2array ] ;
:: let-test-6 ( a -- b )
a [let | a [ ] b [ 1 ] | a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
@ -57,26 +57,26 @@ IN: temporary
with-locals
] unit-test
:: wlet-test-2 | a b |
:: wlet-test-2 ( a b -- seq )
[wlet | add-b [ b + ] |
a [ add-b ] map ] ;
[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
:: wlet-test-3 | a |
:: wlet-test-3 ( a -- b )
[wlet | add-a [ a + ] | [ add-a ] ]
[let | a [ 3 ] | a swap call ] ;
[ 5 ] [ 2 wlet-test-3 ] unit-test
:: wlet-test-4 | a |
:: wlet-test-4 ( a -- b )
[wlet | sub-a [| b | b a - ] |
3 sub-a ] ;
[ -7 ] [ 10 wlet-test-4 ] unit-test
:: write-test-1 | n! |
:: write-test-1 ( n! -- q )
[| i | n i + dup n! ] ;
0 write-test-1 "q" set
@ -89,7 +89,7 @@ IN: temporary
[ 5 ] [ 2 "q" get call ] unit-test
:: write-test-2 | |
:: write-test-2 ( -- q )
[let | n! [ 0 ] |
[| i | n i + dup n! ] ] ;
@ -108,21 +108,55 @@ write-test-2 "q" set
20 10 [| a! | [| b! | a b ] ] with-locals call call
] unit-test
:: write-test-3 | a! | [| b | b a! ] ;
:: write-test-3 ( a! -- q ) [| b | b a! ] ;
[ ] [ 1 2 write-test-3 call ] unit-test
:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ;
:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
[ ] [ 5 write-test-4 drop ] unit-test
SYMBOL: a
:: use-test | a b c |
:: use-test ( a b c -- a b c )
USE: kernel ;
[ t ] [ a symbol? ] unit-test
:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
[ 13 ] [ 10 let-let-test ] unit-test
GENERIC: lambda-generic ( a b -- c )
GENERIC# lambda-generic-1 1 ( a b -- c )
M:: integer lambda-generic-1 ( a b -- c ) a b * ;
M:: string lambda-generic-1 ( a b -- c )
a b CHAR: x <string> lambda-generic ;
M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
GENERIC# lambda-generic-2 1 ( a b -- c )
M:: integer lambda-generic-2 ( a b -- c )
a CHAR: x <string> b lambda-generic ;
M:: string lambda-generic-2 ( a b -- c ) a b append ;
M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ 10 ] [ 5 2 lambda-generic ] unit-test
[ "abab" ] [ "aba" "b" lambda-generic ] unit-test
[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
[ ] [ \ lambda-generic-1 see ] unit-test
[ ] [ \ lambda-generic-2 see ] unit-test
[ ] [ \ lambda-generic see ] unit-test

84
extra/locals/locals.factor
View File

@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private ;
prettyprint.sections sequences.private effects generic
compiler.units ;
IN: locals
! Inspired by
@ -208,9 +209,6 @@ M: object local-rewrite* , ;
: push-locals ( assoc -- )
use get push ;
: parse-locals ( -- words assoc )
"|" parse-tokens make-locals ;
: pop-locals ( assoc -- )
use get delete ;
@ -218,7 +216,7 @@ M: object local-rewrite* , ;
over push-locals parse-until >quotation swap pop-locals ;
: parse-lambda ( -- lambda )
parse-locals \ ] (parse-lambda) <lambda> ;
"|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
: (parse-bindings) ( -- )
scan dup "|" = [
@ -246,11 +244,18 @@ M: wlet local-rewrite*
dup wlet-bindings values over wlet-vars rot wlet-body
<lambda> [ call ] curry compose local-rewrite* \ call , ;
: (::) ( prop -- word quot n )
>r CREATE dup reset-generic
scan "|" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup r> set-word-prop
[ lambda-rewrite first ] keep lambda-vars length ;
: parse-locals
parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
: ((::)) ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: (::) ( -- word quot )
CREATE dup reset-generic ((::)) ;
PRIVATE>
@ -268,9 +273,22 @@ PRIVATE>
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
: :: "lambda" (::) drop define ; parsing
: :: (::) define ; parsing
: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing
! This will be cleaned up when method tuples and method words
! are unified
: create-method ( class generic -- method )
2dup method dup
[ 2nip method-word ]
[ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body )
scan-word bootstrap-word scan-word 2dup
create-method f set-word dup save-location ;
: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
: MACRO:: (::) define-macro ; parsing
<PRIVATE
@ -323,26 +341,42 @@ M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop lambda-body ;
: lambda-word-synopsis ( word prop -- )
over definer.
over seeing-word
over pprint-word
\ | pprint-word
word-prop lambda-vars pprint-vars
\ | pprint-word ;
: lambda-word-synopsis ( word -- )
dup definer.
dup seeing-word
dup pprint-word
stack-effect. ;
M: lambda-word synopsis*
"lambda" lambda-word-synopsis ;
M: lambda-word synopsis* lambda-word-synopsis ;
PREDICATE: macro lambda-macro
"lambda-macro" word-prop >boolean ;
"lambda" word-prop >boolean ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda-macro" word-prop lambda-body ;
"lambda" word-prop lambda-body ;
M: lambda-macro synopsis*
"lambda-macro" lambda-word-synopsis ;
M: lambda-macro synopsis* lambda-word-synopsis ;
PREDICATE: method-body lambda-method
"lambda" word-prop >boolean ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop lambda-body ;
: method-stack-effect
dup "lambda" word-prop lambda-vars
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
<effect> ;
M: lambda-method synopsis*
dup definer.
dup "method" word-prop dup
method-specializer pprint*
method-generic pprint*
method-stack-effect effect>string comment. ;
PRIVATE>

23
extra/macros/macros.factor
View File

@ -1,26 +1,21 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects inference.transforms
combinators assocs definitions quotations namespaces memoize ;
USING: parser kernel sequences words effects
inference.transforms combinators assocs definitions quotations
namespaces memoize ;
IN: macros
: (:) ( -- word definition effect-in )
CREATE dup reset-generic parse-definition
over "declared-effect" word-prop effect-in length ;
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop effect-in 1 <effect> ;
: (MACRO:) ( word definition effect-in -- )
>r 2dup "macro" set-word-prop
2dup over real-macro-effect memoize-quot
[ call ] append define
: define-macro ( word definition -- )
over "declared-effect" word-prop effect-in length >r
2dup "macro" set-word-prop
2dup over real-macro-effect memoize-quot [ call ] append define
r> define-transform ;
: MACRO:
(:) (MACRO:) ; parsing
(:) define-macro ; parsing
PREDICATE: word macro "macro" word-prop >boolean ;

2
extra/math/miller-rabin/miller-rabin.factor
View File

@ -30,7 +30,7 @@ TUPLE: positive-even-expected n ;
#! factor an integer into s * 2^r
0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! |
:: (miller-rabin) ( n prime?! -- ? )
n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set

2
extra/tools/walker/debug/debug.factor
View File

@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations
threads namespaces namespaces.private ;
IN: tools.walker.debug
:: test-walker | quot |
:: test-walker ( quot -- data )
[let | p [ <promise> ]
s [ f <model> ]
c [ f <model> ] |