From 64469916a95296fbdfbe1538ebba6d497cb8c874 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 26 Feb 2008 18:40:32 -0600
Subject: [PATCH 1/7] New locals syntax; added M::
---
core/parser/parser.factor | 2 +
core/syntax/syntax.factor | 2 +-
extra/benchmark/fasta/fasta.factor | 6 +-
extra/channels/examples/examples.factor | 2 +-
extra/cocoa/plists/plists.factor | 1 +
.../exchangers/exchangers-tests.factor | 2 +-
extra/concurrency/locks/locks-tests.factor | 10 +--
extra/crypto/md5/md5.factor | 2 +-
extra/io/sniffer/bsd/bsd.factor | 2 +-
extra/locals/locals-docs.factor | 18 ++--
extra/locals/locals-tests.factor | 86 +++++++++++++------
extra/locals/locals.factor | 84 ++++++++++++------
extra/macros/macros.factor | 23 ++---
extra/math/miller-rabin/miller-rabin.factor | 2 +-
extra/tools/walker/debug/debug.factor | 2 +-
15 files changed, 156 insertions(+), 88 deletions(-)
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 63d3f2e45f..b51374d733 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -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" ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 601c05d8d9..79a5553228 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -107,7 +107,7 @@ IN: bootstrap.syntax
] define-syntax
":" [
- CREATE dup reset-generic parse-definition define
+ (:) define
] define-syntax
"GENERIC:" [
diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 75321def2d..1740bcb28e 100644
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -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 +
diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor
index 993b1db1a4..1e51fb06d8 100755
--- a/extra/channels/examples/examples.factor
+++ b/extra/channels/examples/examples.factor
@@ -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
diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor
index 32b35e9153..646a759c59 100644
--- a/extra/cocoa/plists/plists.factor
+++ b/extra/cocoa/plists/plists.factor
@@ -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 )
diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor
index 3e7f67b9f0..91338389d1 100755
--- a/extra/concurrency/exchangers/exchangers-tests.factor
+++ b/extra/concurrency/exchangers/exchangers-tests.factor
@@ -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> ]
diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor
index 8ebf6856a9..1280339231 100755
--- a/extra/concurrency/locks/locks-tests.factor
+++ b/extra/concurrency/locks/locks-tests.factor
@@ -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
diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor
index fe215e32db..631a7a1020 100644
--- a/extra/crypto/md5/md5.factor
+++ b/extra/crypto/md5/md5.factor
@@ -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+
diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor
index 66336425a1..1c72a4780c 100644
--- a/extra/io/sniffer/bsd/bsd.factor
+++ b/extra/io/sniffer/bsd/bsd.factor
@@ -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 ;
diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor
index 97f9aa5c65..b8d836ecc1 100644
--- a/extra/locals/locals-docs.factor
+++ b/extra/locals/locals-docs.factor
@@ -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 = ] [ ... ] } ;"
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index aa724c4aca..b290c25159 100644
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -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
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 52ccb1bed3..2e6fd6485d 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -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>
diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor
index 7694d9fa84..87b3acd47c 100755
--- a/extra/macros/macros.factor
+++ b/extra/macros/macros.factor
@@ -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 ;
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 8b0d98283c..3985906b32 100755
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -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
diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor
index cfac9d8367..c8c0ff28a6 100755
--- a/extra/tools/walker/debug/debug.factor
+++ b/extra/tools/walker/debug/debug.factor
@@ -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> ] |
From ef53dbd1b944391dd66fcf062039d5fb6d518786 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 26 Feb 2008 19:18:21 -0600
Subject: [PATCH 2/7] Fix load-everything
---
extra/calendar/format/format.factor | 2 +-
extra/io/paths/paths.factor | 2 +-
extra/lcd/lcd.factor | 5 +++--
extra/logging/parser/parser.factor | 2 +-
extra/logging/server/server.factor | 2 +-
extra/project-euler/019/019.factor | 8 ++++----
extra/smtp/smtp.factor | 2 +-
extra/webapps/cgi/cgi.factor | 2 +-
extra/webapps/file/file.factor | 2 +-
extra/webapps/pastebin/pastebin.factor | 2 +-
extra/webapps/planet/planet.factor | 2 +-
extra/windows/time/time.factor | 2 +-
extra/xml-rpc/xml-rpc.factor | 3 ++-
13 files changed, 19 insertions(+), 17 deletions(-)
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index ea8d387e01..75ceea8ea2 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,6 +1,6 @@
IN: calendar.format
USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators ;
+accessors arrays io.streams.string combinators accessors ;
GENERIC: day. ( obj -- )
diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor
index fae07643d5..4acfb9acad 100755
--- a/extra/io/paths/paths.factor
+++ b/extra/io/paths/paths.factor
@@ -1,5 +1,5 @@
USING: io.files kernel sequences new-slots accessors
-dlists arrays ;
+dlists arrays sequences.lib ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor
index c2eba8b7b6..952bc17f17 100755
--- a/extra/lcd/lcd.factor
+++ b/extra/lcd/lcd.factor
@@ -1,5 +1,6 @@
-USING: sequences kernel math io calendar calendar.model
-arrays models namespaces ui.gadgets ui.gadgets.labels
+USING: sequences kernel math io calendar calendar.format
+calendar.model arrays models namespaces ui.gadgets
+ui.gadgets.labels
ui.gadgets.theme ui ;
IN: lcd
diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor
index b4c7e12772..015861501e 100755
--- a/extra/logging/parser/parser.factor
+++ b/extra/logging/parser/parser.factor
@@ -3,7 +3,7 @@
USING: parser-combinators memoize kernel sequences
logging arrays words strings vectors io io.files
namespaces combinators combinators.lib logging.server
-calendar ;
+calendar calendar.format ;
IN: logging.parser
: string-of satisfy <!*> [ >string ] <@ ;
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index e31391e5d5..94d112583a 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -3,7 +3,7 @@
USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging
-threads arrays init math.ranges strings ;
+threads arrays init math.ranges strings calendar.format ;
IN: logging.server
: log-root ( -- string )
diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor
index fd3ca02135..391af05ffa 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -45,14 +45,14 @@ IN: project-euler.019
<PRIVATE
: start-date ( -- timestamp )
- 1901 1 1 0 0 0 0 make-timestamp ;
+ 1901 1 1 0 0 0 0 <timestamp> ;
: end-date ( -- timestamp )
- 2000 12 31 0 0 0 0 make-timestamp ;
+ 2000 12 31 0 0 0 0 <timestamp> ;
: (first-days) ( end-date start-date -- )
- 2dup timestamp- 0 >= [
- dup day-of-week , 1 +month (first-days)
+ 2dup time- 0 >= [
+ dup day-of-week , 1 months time+ (first-days)
] [
2drop
] if ;
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 184bd0c1cc..f3f90f68b9 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
-math.parser random system calendar ;
+math.parser random system calendar calendar.format ;
IN: smtp
diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor
index 1ef83abbe7..5dba9dae00 100755
--- a/extra/webapps/cgi/cgi.factor
+++ b/extra/webapps/cgi/cgi.factor
@@ -14,7 +14,7 @@ SYMBOL: cgi-root
[
"CGI/1.0" "GATEWAY_INTERFACE" set
"HTTP/1.0" "SERVER_PROTOCOL" set
- "Factor " version append "SERVER_SOFTWARE" set
+ "Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" set
diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor
index 898ae35f1a..411c70c76a 100755
--- a/extra/webapps/file/file.factor
+++ b/extra/webapps/file/file.factor
@@ -3,7 +3,7 @@
USING: calendar html io io.files kernel math math.parser
http.server.responders http.server.templating namespaces parser
sequences strings assocs hashtables debugger http.mime sorting
-html.elements logging ;
+html.elements logging calendar.format ;
IN: webapps.file
SYMBOL: doc-root
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 21bae57fe7..36a72795db 100755
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -1,6 +1,6 @@
USING: calendar furnace furnace.validator io.files kernel
namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math ;
+xml.writer xmode.code2html math calendar.format ;
IN: webapps.pastebin
TUPLE: pastebin pastes ;
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 062f6dbce2..9a5f8eeb97 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency.combinators kernel
sorting html.elements io assocs namespaces math threads vocabs
html furnace http.server.templating calendar math.parser
splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging ;
+xml.writer prettyprint logging calendar.format ;
IN: webapps.planet
: print-posting-summary ( posting -- )
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
index 5409edbb75..011f500d88 100755
--- a/extra/windows/time/time.factor
+++ b/extra/windows/time/time.factor
@@ -23,7 +23,7 @@ IN: windows.time
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
- >gmt windows-1601 timestamp- >bignum 10000000 * ;
+ >gmt windows-1601 time- >integer 10000000 * ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor
index a7603a939e..ffccb5e0f5 100644
--- a/extra/xml-rpc/xml-rpc.factor
+++ b/extra/xml-rpc/xml-rpc.factor
@@ -3,7 +3,8 @@
IN: xml-rpc
USING: kernel xml arrays math generic http.client combinators
hashtables namespaces io base64 sequences strings calendar
- xml.data xml.writer xml.utilities assocs math.parser debugger ;
+ xml.data xml.writer xml.utilities assocs math.parser debugger
+ calendar.format ;
! * Sending RPC requests
! TODO: time
From 00ae7633519896670ed7b93779c575e20527867d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 26 Feb 2008 20:03:35 -0600
Subject: [PATCH 3/7] Final calendar cleanup
---
extra/calendar/calendar-tests.factor | 17 ++---
extra/calendar/calendar.factor | 103 ++++++++++++++++-----------
extra/project-euler/019/019.factor | 19 ++---
extra/windows/time/time.factor | 2 +-
4 files changed, 79 insertions(+), 62 deletions(-)
diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index 804c2b5fb1..f700d244f5 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -1,14 +1,15 @@
USING: arrays calendar kernel math sequences tools.test
continuations system ;
-! [ 2004 12 32 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 2 30 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2003 2 29 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 -2 9 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 12 0 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 12 1 24 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 12 1 23 60 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
-! [ 2004 12 1 23 59 60 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
+[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
+[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 leap-year? ] unit-test
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 044553067b..2b80a8dce6 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -37,9 +37,12 @@ C: <duration> duration
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
-: average-month ( -- x )
- #! length of average month in days
- 30.41666666666667 ;
+: average-month 30+5/12 ; inline
+: months-per-year 12 ; inline
+: days-per-year 3652425/10000 ; inline
+: hours-per-year 876582/100 ; inline
+: minutes-per-year 5259492/10 ; inline
+: seconds-per-year 31556952 ; inline
<PRIVATE
@@ -129,7 +132,7 @@ M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
M: real +year ( timestamp n -- timestamp )
- [ float>whole-part swapd 365.2425 * +day swap +year ] unless-zero ;
+ [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
@@ -191,33 +194,37 @@ M: timestamp time+
>r clone r> (time+) drop ;
M: duration time+
- [ year>> ] +slots
- [ month>> ] +slots
- [ day>> ] +slots
- [ hour>> ] +slots
- [ minute>> ] +slots
- [ second>> ] +slots
- 2drop <duration> ;
+ dup timestamp? [
+ swap time+
+ ] [
+ [ year>> ] +slots
+ [ month>> ] +slots
+ [ day>> ] +slots
+ [ hour>> ] +slots
+ [ minute>> ] +slots
+ [ second>> ] +slots
+ 2drop <duration>
+ ] if ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
#! data
0 swap
[ year>> + ] keep
- [ month>> 12 / + ] keep
- [ day>> 365.2425 / + ] keep
- [ hour>> 8765.82 / + ] keep
- [ minute>> 525949.2 / + ] keep
- second>> 31556952.0 / + ;
+ [ month>> months-per-year / + ] keep
+ [ day>> days-per-year / + ] keep
+ [ hour>> hours-per-year / + ] keep
+ [ minute>> minutes-per-year / + ] keep
+ second>> seconds-per-year / + ;
M: duration <=> [ dt>years ] compare ;
-: dt>months ( dt -- x ) dt>years 12 * ;
-: dt>days ( dt -- x ) dt>years 365.2425 * ;
-: dt>hours ( dt -- x ) dt>years 8765.82 * ;
-: dt>minutes ( dt -- x ) dt>years 525949.2 * ;
-: dt>seconds ( dt -- x ) dt>years 31556952 * ;
-: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ;
+: dt>months ( dt -- x ) dt>years months-per-year * ;
+: dt>days ( dt -- x ) dt>years days-per-year * ;
+: dt>hours ( dt -- x ) dt>years hours-per-year * ;
+: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
+: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
+: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
: convert-timezone ( timestamp n -- timestamp )
over gmt-offset>> over = [ drop ] [
@@ -233,26 +240,16 @@ M: duration <=> [ dt>years ] compare ;
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
-: time- ( timestamp timestamp -- seconds )
- #! Exact calendar-time difference
+: (time-) ( timestamp timestamp -- n )
[ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
-: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 0 <timestamp> ; foldable
+GENERIC: time- ( time1 time2 -- time )
-: millis>timestamp ( n -- timestamp )
- >r unix-1970 r> milliseconds time+ ;
-
-: timestamp>millis ( timestamp -- n )
- unix-1970 time- 1000 * >integer ;
-
-: gmt ( -- timestamp )
- #! GMT time, right now
- unix-1970 millis milliseconds time+ ;
-
-: now ( -- timestamp ) gmt >local-time ;
+M: timestamp time-
+ #! Exact calendar-time difference
+ (time-) seconds ;
: before ( dt -- -dt )
[ year>> neg ] keep
@@ -263,10 +260,34 @@ M: timestamp <=> ( ts1 ts2 -- n )
second>> neg
<duration> ;
-: from-now ( dt -- timestamp ) now swap time+ ;
-: ago ( dt -- timestamp ) before from-now ;
+M: duration time-
+ before time+ ;
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
+: <zero> 0 0 0 0 0 0 0 <timestamp> ;
+
+: valid-timestamp? ( timestamp -- ? )
+ clone 0 >>gmt-offset
+ dup <zero> time- <zero> time+ = ;
+
+: unix-1970 ( -- timestamp )
+ 1970 1 1 0 0 0 0 <timestamp> ; foldable
+
+: millis>timestamp ( n -- timestamp )
+ >r unix-1970 r> milliseconds time+ ;
+
+: timestamp>millis ( timestamp -- n )
+ unix-1970 (time-) 1000 * >integer ;
+
+: gmt ( -- timestamp )
+ #! GMT time, right now
+ unix-1970 millis milliseconds time+ ;
+
+: now ( -- timestamp ) gmt >local-time ;
+
+: from-now ( dt -- timestamp ) now swap time+ ;
+: ago ( dt -- timestamp ) now swap time- ;
+
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
@@ -347,7 +368,7 @@ M: timestamp day-of-year ( timestamp -- n )
: beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 >>month ;
-: seconds-since-midnight ( timestamp -- x )
+: time-since-midnight ( timestamp -- duration )
dup beginning-of-day time- ;
M: timestamp sleep-until timestamp>millis sleep-until ;
diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor
index 391af05ffa..a2c3ebcd1f 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -45,25 +45,20 @@ IN: project-euler.019
<PRIVATE
: start-date ( -- timestamp )
- 1901 1 1 0 0 0 0 <timestamp> ;
+ 1901 1 1 <date> ;
: end-date ( -- timestamp )
- 2000 12 31 0 0 0 0 <timestamp> ;
+ 2000 12 31 <date> ;
-: (first-days) ( end-date start-date -- )
- 2dup time- 0 >= [
- dup day-of-week , 1 months time+ (first-days)
- ] [
- 2drop
- ] if ;
-
-: first-days ( start-date end-date -- seq )
- [ swap (first-days) ] { } make ;
+: first-days ( end-date start-date -- days )
+ [ 2dup after=? ]
+ [ dup 1 months time+ swap day-of-week ]
+ [ ] unfold 2nip ;
PRIVATE>
: euler019a ( -- answer )
- start-date end-date first-days [ zero? ] count ;
+ end-date start-date first-days [ zero? ] count ;
! [ euler019a ] 100 ave-time
! 131 ms run / 3 ms GC ave time - 100 trials
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
index 011f500d88..62d2805f01 100755
--- a/extra/windows/time/time.factor
+++ b/extra/windows/time/time.factor
@@ -23,7 +23,7 @@ IN: windows.time
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
- >gmt windows-1601 time- >integer 10000000 * ;
+ >gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
From a10604910c50d694fc580eb3c5f26ade45b08cdc Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 26 Feb 2008 20:14:09 -0600
Subject: [PATCH 4/7] unix: fix typedefs
---
extra/unix/unix.factor | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 9d5a6122a2..bfe7ad009c 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -6,10 +6,11 @@ math namespaces system combinators vocabs.loader ;
! ! ! Unix types
TYPEDEF: int blksize_t
-TYPEDEF: int dev_t
+! TYPEDEF: int dev_t
TYPEDEF: long ssize_t
-TYPEDEF: longlong blkcnt_t
+TYPEDEF: long blkcnt_t
TYPEDEF: longlong quad_t
+TYPEDEF: ulonglong dev_t
TYPEDEF: uint gid_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint ino_t
@@ -19,8 +20,9 @@ TYPEDEF: uint time_t
TYPEDEF: uint uid_t
TYPEDEF: ulong size_t
TYPEDEF: ulong u_long
-TYPEDEF: ushort mode_t
-TYPEDEF: ushort nlink_t
+! TYPEDEF: ushort mode_t
+TYPEDEF: uint mode_t
+TYPEDEF: uint nlink_t
TYPEDEF: void* caddr_t
TYPEDEF: ulong off_t
@@ -226,3 +228,4 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{ [ solaris? ] [ "unix.solaris" require ] }
{ [ t ] [ ] }
} cond
+
From f1954e92d2e9e7f85d80ad0fcf2564fed836f4a7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 26 Feb 2008 20:20:22 -0600
Subject: [PATCH 5/7] Obsolete unit tests
---
extra/calendar/unix/unix-tests.factor | 13 -------------
1 file changed, 13 deletions(-)
delete mode 100644 extra/calendar/unix/unix-tests.factor
diff --git a/extra/calendar/unix/unix-tests.factor b/extra/calendar/unix/unix-tests.factor
deleted file mode 100644
index a35a60c6f3..0000000000
--- a/extra/calendar/unix/unix-tests.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-USING: alien alien.c-types calendar calendar.unix
-kernel math tools.test ;
-
-[ t ] [ 239293000 [
- unix-time>timestamp timestamp>timeval
- timeval>timestamp timestamp>timeval *ulong
-] keep = ] unit-test
-
-
-[ t ] [ 23929000.3 [
- unix-time>timestamp timestamp>timeval
- timeval>timestamp timestamp>timeval *ulong
-] keep >bignum = ] unit-test
From 6dcc85ecc2e7979c7606f8e2eeb38141bdeee6a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Tue, 26 Feb 2008 20:20:30 -0600
Subject: [PATCH 6/7] Refactor help lint for builder
---
extra/help/lint/lint-docs.factor | 14 ++++-----
extra/help/lint/lint.factor | 51 +++++++++++++++++++++++---------
2 files changed, 44 insertions(+), 21 deletions(-)
diff --git a/extra/help/lint/lint-docs.factor b/extra/help/lint/lint-docs.factor
index 2813391d07..6aa3310bf9 100644
--- a/extra/help/lint/lint-docs.factor
+++ b/extra/help/lint/lint-docs.factor
@@ -1,26 +1,26 @@
USING: help.markup help.syntax ;
IN: help.lint
-HELP: check-help
-{ $description "Checks all word and article help." } ;
+HELP: help-lint-all
+{ $description "Checks all word help and articles in all loaded vocabularies." } ;
-HELP: check-vocab-help
+HELP: help-lint
{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Checks all word help in the given vocabulary." } ;
+{ $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ;
ARTICLE: "help.lint" "Help lint tool"
"The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write."
$nl
"To run help lint, use one of the following two words:"
-{ $subsection check-help }
-{ $subsection check-vocab-help }
+{ $subsection help-lint }
+{ $subsection help-lint-all }
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"
{ "ensures " { $link $see-also } " elements don't contain duplicate entries" }
{ "ensures " { $link $vocab-link } " elements point to modules which actually exist" }
{ "ensures that " { $link $values } " match the stack effect declaration" }
- { "ensures that word help articles actually render (this catches broken links, improper nesting, etc)" }
+ { "ensures that help topics actually render (this catches broken links, improper nesting, etc)" }
} ;
ABOUT: "help.lint"
diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor
index 3c11a93509..4b97499a4c 100644
--- a/extra/help/lint/lint.factor
+++ b/extra/help/lint/lint.factor
@@ -5,7 +5,7 @@ words strings classes tools.browser namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib ;
+macros combinators.lib sequences.lib ;
IN: help.lint
: check-example ( element -- )
@@ -84,7 +84,7 @@ M: help-error error.
delegate error. ;
: check-something ( obj quot -- )
- over . flush [ <help-error> , ] recover ; inline
+ flush [ <help-error> , ] recover ; inline
: check-word ( word -- )
dup word-help [
@@ -106,22 +106,45 @@ M: help-error error.
[ dup check-rendering ] assert-depth drop
] check-something ;
-: check-articles ( -- )
- articles get keys [ check-article ] each ;
+: group-articles ( -- assoc )
+ articles get keys
+ vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
+ H{ } clone [
+ [
+ >r >r dup >link where ?first r> at r> [ ?push ] change-at
+ ] 2curry each
+ ] keep ;
-: with-help-lint ( quot -- )
+: check-vocab ( vocab -- seq )
+ "Checking " write dup write "..." print
+ [
+ dup words [ check-word ] each
+ "vocab-articles" get at [ check-article ] each
+ ] { } make ;
+
+: run-help-lint ( prefix -- alist )
[
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- call
- ] { } make [ nl error. ] each ; inline
+ articles get keys "group-articles" set
+ child-vocabs
+ [ dup check-vocab ] { } map>assoc
+ [ nip empty? not ] assoc-subset
+ ] with-scope ;
-: check-help ( -- )
- [ all-words check-words check-articles ] with-help-lint ;
+: typos. ( assoc -- )
+ dup empty? [
+ drop
+ "==== ALL CHECKS PASSED" print
+ ] [
+ [
+ swap vocab-heading.
+ [ error. nl ] each
+ ] assoc-each
+ ] if ;
-: check-vocab-help ( vocab -- )
- [
- child-vocabs [ words check-words ] each
- ] with-help-lint ;
+: help-lint ( prefix -- ) run-help-lint typos. ;
+
+: help-lint-all ( -- ) "" help-lint ;
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] subset ;
@@ -132,4 +155,4 @@ M: help-error error.
[ article-parent ] subset
[ "predicating" word-prop not ] subset ;
-MAIN: check-help
+MAIN: help-lint
From 1ac3baa4c5288247592e977b6307d9b514ce3643 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@terrorist.(none)>
Date: Tue, 26 Feb 2008 20:59:46 -0600
Subject: [PATCH 7/7] unix: fix more typedefs
---
extra/unix/unix.factor | 17 +++++++++++------
1 file changed, 11 insertions(+), 6 deletions(-)
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index bfe7ad009c..7df41069e0 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -5,24 +5,29 @@ USING: alien alien.c-types alien.syntax kernel libc structs
math namespaces system combinators vocabs.loader ;
! ! ! Unix types
-TYPEDEF: int blksize_t
-! TYPEDEF: int dev_t
+
+TYPEDEF: long word
+TYPEDEF: ulong uword
+
+TYPEDEF: long longword
+TYPEDEF: ulong ulongword
+
TYPEDEF: long ssize_t
-TYPEDEF: long blkcnt_t
+TYPEDEF: longword blksize_t
+TYPEDEF: longword blkcnt_t
TYPEDEF: longlong quad_t
TYPEDEF: ulonglong dev_t
TYPEDEF: uint gid_t
TYPEDEF: uint in_addr_t
-TYPEDEF: uint ino_t
+TYPEDEF: ulong ino_t
TYPEDEF: int pid_t
TYPEDEF: uint socklen_t
TYPEDEF: uint time_t
TYPEDEF: uint uid_t
TYPEDEF: ulong size_t
TYPEDEF: ulong u_long
-! TYPEDEF: ushort mode_t
TYPEDEF: uint mode_t
-TYPEDEF: uint nlink_t
+TYPEDEF: uword nlink_t
TYPEDEF: void* caddr_t
TYPEDEF: ulong off_t