diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index def5b02ba0..a756734f7b 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -3,7 +3,8 @@
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects prettyprint
-prettyprint.sections prettyprint.backend assocs combinators ;
+prettyprint.sections prettyprint.backend assocs combinators
+lexer strings.parser ;
IN: alien.syntax
<PRIVATE
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 0fef6de748..35ff475abf 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -65,6 +65,15 @@ GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
+M: class reset-class
+ {
+ "class"
+ "metaclass"
+ "superclass"
+ "members"
+ "participants"
+ } reset-props ;
+
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 7ea8e24f0a..cc24280384 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -27,7 +27,4 @@ M: intersection-class update-class define-intersection-predicate ;
[ drop update-classes ]
2bi ;
-M: intersection-class reset-class
- { "class" "metaclass" "participants" } reset-props ;
-
M: intersection-class rank-class drop 2 ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index a2debe55a1..3924eb264c 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
- { "class" "metaclass" "members" "mixin" } reset-props ;
+ [ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor
new file mode 100644
index 0000000000..17a7b23552
--- /dev/null
+++ b/core/classes/parser/parser.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words kernel classes compiler.units lexer ;
+IN: classes.parser
+
+: save-class-location ( class -- )
+ location remember-class ;
+
+: create-class-in ( word -- word )
+ current-vocab create
+ dup save-class-location
+ dup predicate-word dup set-word save-location ;
+
+: CREATE-CLASS ( -- word )
+ scan create-class-in ;
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index c8de36582e..7ea60149f8 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -24,11 +24,8 @@ PREDICATE: predicate-class < class
] 3tri ;
M: predicate-class reset-class
- {
- "class"
- "metaclass"
- "predicate-definition"
- "superclass"
- } reset-props ;
+ [ call-next-method ]
+ [ { "predicate-definition" } reset-props ]
+ bi ;
M: predicate-class rank-class drop 1 ;
diff --git a/core/classes/tuple/parser/parser-docs.factor b/core/classes/tuple/parser/parser-docs.factor
new file mode 100644
index 0000000000..f4ecb1461e
--- /dev/null
+++ b/core/classes/tuple/parser/parser-docs.factor
@@ -0,0 +1,14 @@
+IN: classes.tuple.parser
+USING: strings help.markup help.syntax ;
+
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+ { $code
+ "TUPLE: my-mistaken-tuple slot-a slot-b"
+ ""
+ ": some-word ( a b c -- ) ... ;"
+ }
+} ;
diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
new file mode 100644
index 0000000000..ab3be109e1
--- /dev/null
+++ b/core/classes/tuple/parser/parser.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sets namespaces sequences inspector parser
+lexer combinators words classes.parser classes.tuple ;
+IN: classes.tuple.parser
+
+: shadowed-slots ( superclass slots -- shadowed )
+ >r all-slot-names r> intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+ shadowed-slots [
+ [
+ "Definition of slot ``" %
+ %
+ "'' in class ``" %
+ word-name %
+ "'' shadows a superclass slot" %
+ ] "" make note.
+ ] with each ;
+
+ERROR: invalid-slot-name name ;
+
+M: invalid-slot-name summary
+ drop
+ "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+ #! This isn't meant to enforce any kind of policy, just
+ #! to check for mistakes of this form:
+ #!
+ #! TUPLE: blahblah foo bing
+ #!
+ #! : ...
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop ] }
+ [ , (parse-tuple-slots) ]
+ } cond ;
+
+: parse-tuple-slots ( -- seq )
+ [ (parse-tuple-slots) ] { } make ;
+
+: parse-tuple-definition ( -- class superclass slots )
+ CREATE-CLASS
+ scan {
+ { ";" [ tuple f ] }
+ { "<" [ scan-word parse-tuple-slots ] }
+ [ >r tuple parse-tuple-slots r> prefix ]
+ } case 3dup check-slot-shadowing ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 604914bd5c..c93bd11ffe 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order classes.private ;
+columns math.order classes.private slots.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
- size-test tuple-size =
+ size-test tuple-layout layout-size =
] unit-test
GENERIC: <yo-momma>
@@ -220,7 +220,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ error>> no-tuple-class? ] must-fail-with
+] [ error>> not-a-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
@@ -252,7 +252,7 @@ C: <laptop> laptop
test-laptop-slot-values
[ laptop ] [
- "laptop" get tuple-layout
+ "laptop" get 1 slot
dup layout-echelon swap
layout-superclasses nth
] unit-test
@@ -490,7 +490,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
@@ -595,3 +595,6 @@ GENERIC: break-me ( obj -- )
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
+
+! Insufficient type checking
+[ \ vocab tuple>array drop ] must-fail
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 5ba0b7e69c..df59f34ff4 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -9,32 +9,32 @@ IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ;
-ERROR: no-tuple-class class ;
+ERROR: not-a-tuple object ;
+
+: check-tuple ( object -- tuple )
+ dup tuple? [ not-a-tuple ] unless ; inline
+
+ERROR: not-a-tuple-class class ;
+
+: check-tuple-class ( class -- class )
+ dup tuple-class? [ not-a-tuple-class ] unless ; inline
<PRIVATE
-GENERIC: tuple-layout ( object -- layout )
+: tuple-layout ( class -- layout )
+ check-tuple-class "layout" word-prop ;
-M: tuple-class tuple-layout "layout" word-prop ;
-
-M: tuple tuple-layout 1 slot ;
-
-M: tuple-layout tuple-layout ;
-
-: tuple-size tuple-layout layout-size ; inline
+: tuple-size ( tuple -- size )
+ 1 slot layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- [ tuple-size ] [ ] [ tuple-layout ] tri ;
+ check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
PRIVATE>
-: check-tuple ( class -- )
- dup tuple-class?
- [ drop ] [ no-tuple-class ] if ;
-
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
@@ -63,7 +63,7 @@ ERROR: bad-superclass class ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ tuple-layout ] bi@ eq? [
+ 2dup [ 1 slot ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
@@ -217,13 +217,9 @@ M: tuple-class reset-class
[ writer-word method forget ] 2bi
] with each
] [
- {
- "class"
- "metaclass"
- "superclass"
- "layout"
- "slots"
- } reset-props
+ [ call-next-method ]
+ [ { "layout" "slots" } reset-props ]
+ bi
] bi ;
M: tuple-class rank-class drop 0 ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 74e29cfb01..819e0ecb0b 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -28,7 +28,4 @@ M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ (define-union-class) ] [ drop update-classes ] 2bi ;
-M: union-class reset-class
- { "class" "metaclass" "members" } reset-props ;
-
M: union-class rank-class drop 2 ;
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 4ee2fd5cdf..093b215013 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -46,7 +46,6 @@ SYMBOL: +failed+
] tri ;
: (compile) ( word -- )
- dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 3cb7d8a71e..f176e6ee19 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
-continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+continuations.private vectors arrays namespaces
+assocs words quotations lexer ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@@ -169,8 +169,8 @@ HELP: rethrow
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
}
{ $examples
- "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
- { $see with-parser }
+ "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
+ { $see with-lexer }
} ;
HELP: throw-restarts
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 452a102341..f8e0b0abb0 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
-combinators kernel.private math namespaces parser sequences
-words system layouts math.order accessors ;
+combinators kernel.private math namespaces sequences
+words system layouts math.order accessors
+cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@@ -12,21 +13,6 @@ IN: cpu.x86.assembler
! Beware!
! Register operands -- eg, ECX
-<<
-
-: define-register ( name num size -- )
- >r >r "cpu.x86.assembler" create dup define-symbol r> r>
- >r dupd "register" set-word-prop r>
- "register-size" set-word-prop ;
-
-: define-registers ( names size -- )
- >r dup length r> [ define-register ] curry 2each ;
-
-: REGISTERS: ( -- )
- scan-word ";" parse-tokens swap define-registers ; parsing
-
->>
-
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
diff --git a/core/cpu/x86/assembler/syntax/syntax.factor b/core/cpu/x86/assembler/syntax/syntax.factor
new file mode 100644
index 0000000000..5940663d42
--- /dev/null
+++ b/core/cpu/x86/assembler/syntax/syntax.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences lexer parser ;
+IN: cpu.x86.assembler.syntax
+
+: define-register ( name num size -- )
+ >r >r "cpu.x86.assembler" create dup define-symbol r> r>
+ >r dupd "register" set-word-prop r>
+ "register-size" set-word-prop ;
+
+: define-registers ( names size -- )
+ >r dup length r> [ define-register ] curry 2each ;
+
+: REGISTERS: ( -- )
+ scan-word ";" parse-tokens swap define-registers ; parsing
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index cfad144737..2ac903a39b 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -209,8 +209,11 @@ M: inconsistent-next-method summary
M: check-method summary
drop "Invalid parameters for create-method" ;
-M: no-tuple-class summary
- drop "BOA constructors can only be defined for tuple classes" ;
+M: not-a-tuple summary
+ drop "Not a tuple" ;
+
+M: not-a-tuple-class summary
+ drop "Not a tuple class" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 099260f111..d7923ad595 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ;
GENERIC: stack-effect ( word -- effect/f )
-M: symbol stack-effect drop 0 1 <effect> ;
+M: symbol stack-effect drop (( -- symbol )) ;
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
- [ in>> clone ] keep effect-out clone <effect> ;
+ [ in>> clone ] [ out>> clone ] bi <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
diff --git a/core/effects/parser/parser-docs.factor b/core/effects/parser/parser-docs.factor
new file mode 100644
index 0000000000..6cb39d208d
--- /dev/null
+++ b/core/effects/parser/parser-docs.factor
@@ -0,0 +1,9 @@
+IN: effects.parser
+USING: strings effects help.markup help.syntax ;
+
+HELP: parse-effect
+{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
+{ $description "Parses a stack effect from the current input line." }
+{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
+$parsing-note ;
+
diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
new file mode 100644
index 0000000000..8f28450de7
--- /dev/null
+++ b/core/effects/parser/parser.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: lexer sets sequences kernel splitting effects ;
+IN: effects.parser
+
+: parse-effect ( end -- effect )
+ parse-tokens dup { "(" "((" } intersect empty? [
+ { "--" } split1 dup [
+ <effect>
+ ] [
+ "Stack effect declaration must contain --" throw
+ ] if
+ ] [
+ "Stack effect declaration must not contain ( or ((" throw
+ ] if ;
diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor
new file mode 100644
index 0000000000..ba9cd5244c
--- /dev/null
+++ b/core/generic/parser/parser.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel words generic namespaces inspector ;
+IN: generic.parser
+
+ERROR: not-in-a-method-error ;
+
+M: not-in-a-method-error summary
+ drop "call-next-method can only be called in a method definition" ;
+
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: create-method-in ( class generic -- method )
+ create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+ scan-word bootstrap-word scan-word create-method-in ;
+
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: with-method-definition ( quot -- parsed )
+ [
+ >r
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ r> call
+ ] with-scope ; inline
+
+: (M:) ( method def -- )
+ CREATE-METHOD [ parse-definition ] with-method-definition ;
+
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index f8b071e803..59fbd289db 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -228,7 +228,7 @@ M: object constructor drop f ;
1 infer->r
peek-d reify-curry
1 infer-r>
- 2 1 <effect> swap #call consume/produce
+ (( obj quot -- curry )) swap #call consume/produce
] when* ;
: reify-curries ( n -- )
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index f90dd2350c..7f5f8035fb 100755
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -1,7 +1,7 @@
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
quotations inference accessors combinators words arrays
-classes ;
+classes classes.tuple ;
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
: compose-n ( quot -- ) compose-n-quot call ;
@@ -46,3 +46,9 @@ C: <color> color
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
[ fixnum instance? ] must-infer
+
+: bad-new-test ( -- obj ) V{ } new ;
+
+[ bad-new-test ] must-infer
+
+[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 5ca10c7545..8fc72b0f09 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic sets definitions ;
+inference.dataflow inference.state classes.tuple
+classes.tuple.private effects inspector hashtables classes
+generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -83,19 +84,26 @@ M: duplicated-slots-error summary
] 1 define-transform
\ boa [
- dup +inlined+ depends-on
- tuple-layout [ <tuple-boa> ] curry
+ dup tuple-class? [
+ dup +inlined+ depends-on
+ tuple-layout [ <tuple-boa> ] curry
+ ] [
+ [ not-a-tuple-class ] curry time-bomb
+ ] if
] 1 define-transform
\ new [
1 ensure-values
peek-d value? [
- pop-literal
- dup +inlined+ depends-on
- tuple-layout [ <tuple> ] curry
- swap infer-quot
+ pop-literal dup tuple-class? [
+ dup +inlined+ depends-on
+ tuple-layout [ <tuple> ] curry
+ swap infer-quot
+ ] [
+ \ not-a-tuple-class boa time-bomb drop
+ ] if
] [
- \ new 1 1 <effect> make-call-node
+ \ new (( class -- tuple )) make-call-node
] if
] "infer" set-word-prop
diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor
index 72c1a9a6bf..c230364342 100644
--- a/core/inspector/inspector-tests.factor
+++ b/core/inspector/inspector-tests.factor
@@ -9,3 +9,29 @@ H{ } describe
H{ } describe
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+
+[ ] [ inspector-hook get-global inspector-hook set ] unit-test
+
+[ ] [ H{ } clone inspect ] unit-test
+
+[ ] [ "a" "b" &add ] unit-test
+
+[ H{ { "b" "a" } } ] [ me get ] unit-test
+
+[ ] [ "x" 0 &put ] unit-test
+
+[ H{ { "b" "x" } } ] [ me get ] unit-test
+
+[ ] [ 0 &at ] unit-test
+
+[ "x" ] [ me get ] unit-test
+
+[ ] [ &back ] unit-test
+
+[ ] [ "y" 0 &rename ] unit-test
+
+[ H{ { "y" "x" } } ] [ me get ] unit-test
+
+[ ] [ 0 &delete ] unit-test
+
+[ H{ } ] [ me get ] unit-test
diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor
index fd4e11901a..d32f1c90cf 100755
--- a/core/inspector/inspector.factor
+++ b/core/inspector/inspector.factor
@@ -3,7 +3,7 @@
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
quotations mirrors splitting math.parser classes vocabs refs
-sets ;
+sets sorting ;
IN: inspector
GENERIC: summary ( object -- string )
@@ -78,10 +78,17 @@ SYMBOL: +editable+
: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: sorted-keys ( assoc -- alist )
+ dup mirror? [ keys ] [
+ keys
+ [ [ unparse-short ] keep ] { } map>assoc
+ sort-keys values
+ ] if ;
+
: describe* ( obj flags -- )
clone [
dup summary.
- make-mirror dup keys dup empty? [
+ make-mirror dup sorted-keys dup empty? [
2drop
] [
dup enum? [ +sequence+ on ] when
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 4b129ad59d..c5bd0615a7 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -117,3 +117,8 @@ IN: kernel.tests
: total-failure-2 [ ] (call) unimplemented ;
[ total-failure-2 ] must-fail
+
+! From combinators.lib
+[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
+[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
+[ [ sq ] tri@ ] must-infer
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
new file mode 100644
index 0000000000..a7dcb161e5
--- /dev/null
+++ b/core/lexer/lexer-docs.factor
@@ -0,0 +1,109 @@
+IN: lexer
+USING: help.markup help.syntax kernel math sequences strings
+words quotations ;
+
+HELP: lexer
+{ $var-description "Stores the current " { $link lexer } " instance." }
+{ $class-description "An object for tokenizing parser input. It has the following slots:"
+ { $list
+ { { $snippet "text" } " - the lines being parsed; an array of strings" }
+ { { $snippet "line" } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" }
+ { { $snippet "column" } " - the current column position, zero-based" }
+ }
+"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ;
+
+HELP: <lexer>
+{ $values { "text" "a sequence of strings" } { "lexer" lexer } }
+{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ;
+
+HELP: next-line
+{ $values { "lexer" lexer } }
+{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
+
+HELP: lexer-error
+{ $error-description "Thrown when the lexer encounters invalid input. A lexer error wraps an underlying error together with line and column numbers." } ;
+
+HELP: <lexer-error>
+{ $values { "msg" "an error" } { "error" lexer-error } }
+{ $description "Creates a new " { $link lexer-error } ", filling in the location information from the current " { $link lexer } "." } ;
+
+HELP: skip
+{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
+{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
+
+HELP: change-lexer-column
+{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
+{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
+
+HELP: skip-blank
+{ $values { "lexer" lexer } }
+{ $contract "Skips whitespace characters." }
+{ $notes "Custom lexers can implement this generic word." } ;
+
+HELP: skip-word
+{ $values { "lexer" lexer } }
+{ $contract
+ "Skips until the end of the current token."
+ $nl
+ "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line."
+}
+{ $notes "Custom lexers can implement this generic word." } ;
+
+HELP: still-parsing-line?
+{ $values { "lexer" lexer } { "?" "a boolean" } }
+{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
+
+HELP: parse-token
+{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
+
+HELP: scan
+{ $values { "str/f" "a " { $link string } " or " { $link f } } }
+{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+$parsing-note ;
+
+HELP: still-parsing?
+{ $values { "lexer" lexer } { "?" "a boolean" } }
+{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
+
+HELP: parse-tokens
+{ $values { "end" string } { "seq" "a new sequence of strings" } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
+{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+$parsing-note ;
+
+HELP: unexpected
+{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
+{ $description "Throws an " { $link unexpected } " error." }
+{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
+{ $examples
+ "Parsing the following snippet will throw this error:"
+ { $code "[ 1 2 3 }" }
+} ;
+
+HELP: unexpected-eof
+{ $values { "word" "a " { $link word } } }
+{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ;
+
+HELP: with-lexer
+{ $values { "lexer" lexer } { "quot" quotation } }
+{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ;
+
+HELP: lexer-factory
+{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
+
+
+ARTICLE: "parser-lexer" "The lexer"
+"A variable that encapsulate internal parser state:"
+{ $subsection lexer }
+"Creating a default lexer:"
+{ $subsection <lexer> }
+"A word to test of the end of input has been reached:"
+{ $subsection still-parsing? }
+"A word to advance the lexer to the next line:"
+{ $subsection next-line }
+"Two generic words to override the lexer's token boundary detection:"
+{ $subsection skip-blank }
+{ $subsection skip-word }
+"Utility combinator:"
+{ $subsection with-lexer } ;
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
new file mode 100644
index 0000000000..3d65fb95ca
--- /dev/null
+++ b/core/lexer/lexer.factor
@@ -0,0 +1,133 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces math words strings
+debugger io vectors arrays math.parser combinators inspector
+continuations ;
+IN: lexer
+
+TUPLE: lexer text line line-text line-length column ;
+
+: next-line ( lexer -- )
+ dup [ line>> ] [ text>> ] bi ?nth >>line-text
+ dup line-text>> length >>line-length
+ [ 1+ ] change-line
+ 0 >>column
+ drop ;
+
+: new-lexer ( text class -- lexer )
+ new
+ 0 >>line
+ swap >>text
+ dup next-line ; inline
+
+: <lexer> ( text -- lexer )
+ lexer new-lexer ;
+
+: skip ( i seq ? -- n )
+ over >r
+ [ swap CHAR: \s eq? xor ] curry find-from drop
+ [ r> drop ] [ r> length ] if* ;
+
+: change-lexer-column ( lexer quot -- )
+ swap
+ [ dup lexer-column swap lexer-line-text rot call ] keep
+ set-lexer-column ; inline
+
+GENERIC: skip-blank ( lexer -- )
+
+M: lexer skip-blank ( lexer -- )
+ [ t skip ] change-lexer-column ;
+
+GENERIC: skip-word ( lexer -- )
+
+M: lexer skip-word ( lexer -- )
+ [
+ 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
+ ] change-lexer-column ;
+
+: still-parsing? ( lexer -- ? )
+ dup lexer-line swap lexer-text length <= ;
+
+: still-parsing-line? ( lexer -- ? )
+ dup lexer-column swap lexer-line-length < ;
+
+: (parse-token) ( lexer -- str )
+ [ lexer-column ] keep
+ [ skip-word ] keep
+ [ lexer-column ] keep
+ lexer-line-text subseq ;
+
+: parse-token ( lexer -- str/f )
+ dup still-parsing? [
+ dup skip-blank
+ dup still-parsing-line?
+ [ (parse-token) ] [ dup next-line parse-token ] if
+ ] [ drop f ] if ;
+
+: scan ( -- str/f ) lexer get parse-token ;
+
+ERROR: unexpected want got ;
+
+GENERIC: expected>string ( obj -- str )
+
+M: f expected>string drop "end of input" ;
+M: word expected>string word-name ;
+M: string expected>string ;
+
+M: unexpected error.
+ "Expected " write
+ dup unexpected-want expected>string write
+ " but got " write
+ unexpected-got expected>string print ;
+
+PREDICATE: unexpected-eof < unexpected
+ unexpected-got not ;
+
+: unexpected-eof ( word -- * ) f unexpected ;
+
+: (parse-tokens) ( accum end -- accum )
+ scan 2dup = [
+ 2drop
+ ] [
+ [ pick push (parse-tokens) ] [ unexpected-eof ] if*
+ ] if ;
+
+: parse-tokens ( end -- seq )
+ 100 <vector> swap (parse-tokens) >array ;
+
+TUPLE: lexer-error line column line-text error ;
+
+: <lexer-error> ( msg -- error )
+ \ lexer-error new
+ lexer get
+ [ line>> >>line ]
+ [ column>> >>column ]
+ [ line-text>> >>line-text ]
+ tri
+ swap >>error ;
+
+: lexer-dump ( error -- )
+ [ line>> number>string ": " append ]
+ [ line-text>> dup string? [ drop "" ] unless ]
+ [ column>> 0 or ] tri
+ pick length + CHAR: \s <string>
+ [ write ] [ print ] [ write "^" print ] tri* ;
+
+M: lexer-error error.
+ [ lexer-dump ] [ error>> error. ] bi ;
+
+M: lexer-error summary
+ error>> summary ;
+
+M: lexer-error compute-restarts
+ error>> compute-restarts ;
+
+M: lexer-error error-help
+ error>> error-help ;
+
+: with-lexer ( lexer quot -- newquot )
+ [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
+
+SYMBOL: lexer-factory
+
+[ <lexer> ] lexer-factory set-global
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index e00e64f4bc..4e2a8c768e 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
-namespaces parser sequences strings io.styles
+namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors ;
IN: listener
@@ -51,7 +51,7 @@ SYMBOL: error-hook
listener-hook get call prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
- dup parse-error? [
+ dup lexer-error? [
error-hook get call
] [
rethrow
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index 0a49163075..607ba1542f 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint accessors ;
+quotations accessors ;
IN: mirrors
: all-slots ( class -- slots )
@@ -47,13 +47,8 @@ M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
-: sort-assoc ( assoc -- alist )
- >alist
- [ [ first unparse-short ] keep ] { } map>assoc
- sort-keys values ;
-
GENERIC: make-mirror ( obj -- assoc )
-M: hashtable make-mirror sort-assoc ;
+M: hashtable make-mirror ;
M: integer make-mirror drop f ;
M: array make-mirror <enum> ;
M: vector make-mirror <enum> ;
diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor
index 8b5e25deb1..30a726e022 100644
--- a/core/optimizer/math/partial/partial.factor
+++ b/core/optimizer/math/partial/partial.factor
@@ -59,7 +59,7 @@ PREDICATE: math-partial < word
: define-integer-op-word ( word fix-word big-word -- )
[
[ integer-op-word ] [ integer-op-quot ] 3bi
- 2 1 <effect> define-declared
+ (( x y -- z )) define-declared
]
[
[ integer-op-word ] [ 2drop ] 3bi
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 2ec9f2de54..1aecfbd60d 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units assocs ;
+quotations namespaces compiler.units assocs lexer ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
@@ -135,25 +135,6 @@ $nl
{ $subsection "defining-words" }
{ $subsection "parsing-tokens" } ;
-ARTICLE: "parser-lexer" "The lexer"
-"Two variables that encapsulate internal parser state:"
-{ $subsection file }
-{ $subsection lexer }
-"Creating a default lexer:"
-{ $subsection <lexer> }
-"A word to test of the end of input has been reached:"
-{ $subsection still-parsing? }
-"A word to advance the lexer to the next line:"
-{ $subsection next-line }
-"Two generic words to override the lexer's token boundary detection:"
-{ $subsection skip-blank }
-{ $subsection skip-word }
-"A utility used when parsing string literals:"
-{ $subsection parse-string }
-"The parser can be invoked with a custom lexer:"
-{ $subsection (parse-lines) }
-{ $subsection with-parser } ;
-
ARTICLE: "parser-files" "Parsing source files"
"The parser can run source files:"
{ $subsection run-file }
@@ -192,25 +173,6 @@ $nl
ABOUT: "parser"
-: $parsing-note ( children -- )
- drop
- "This word should only be called from parsing words."
- $notes ;
-
-HELP: lexer
-{ $var-description "Stores the current " { $link lexer } " instance." }
-{ $class-description "An object for tokenizing parser input. It has the following slots:"
- { $list
- { { $link lexer-text } " - the lines being parsed; an array of strings" }
- { { $link lexer-line } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" }
- { { $link lexer-column } " - the current column position, zero-based" }
- }
-"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ;
-
-HELP: <lexer>
-{ $values { "text" "a sequence of strings" } { "lexer" lexer } }
-{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ;
-
HELP: location
{ $values { "loc" "a " { $snippet "{ path line# }" } " pair" } }
{ $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ;
@@ -226,73 +188,9 @@ HELP: parser-notes?
{ $values { "?" "a boolean" } }
{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ;
-HELP: next-line
-{ $values { "lexer" lexer } }
-{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ;
-
-HELP: parse-error
-{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ;
-
-HELP: <parse-error>
-{ $values { "msg" "an error" } { "error" parse-error } }
-{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ;
-
-HELP: skip
-{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
-{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
-
-HELP: change-lexer-column
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
-{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
-
-HELP: skip-blank
-{ $values { "lexer" lexer } }
-{ $contract "Skips whitespace characters." }
-{ $notes "Custom lexers can implement this generic word." } ;
-
-HELP: skip-word
-{ $values { "lexer" lexer } }
-{ $contract
- "Skips until the end of the current token."
- $nl
- "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line."
-}
-{ $notes "Custom lexers can implement this generic word." } ;
-
-HELP: still-parsing-line?
-{ $values { "lexer" lexer } { "?" "a boolean" } }
-{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
-
-HELP: parse-token
-{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
-{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
-
-HELP: scan
-{ $values { "str/f" "a " { $link string } " or " { $link f } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
-$parsing-note ;
-
-HELP: bad-escape
-{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ;
-
HELP: bad-number
{ $error-description "Indicates the parser encountered an invalid numeric literal." } ;
-HELP: escape
-{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
-{ $description "Converts from a single-character escape code and the corresponding character." }
-{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
-
-HELP: parse-string
-{ $values { "str" "a new " { $link string } } }
-{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
-{ $errors "Throws an error if the string contains an invalid escape sequence." }
-$parsing-note ;
-
-HELP: still-parsing?
-{ $values { "lexer" lexer } { "?" "a boolean" } }
-{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
-
HELP: use
{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ;
@@ -338,12 +236,6 @@ HELP: create-in
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
$parsing-note ;
-HELP: parse-tokens
-{ $values { "end" string } { "seq" "a new sequence of strings" } }
-{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
-{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
-$parsing-note ;
-
HELP: CREATE
{ $values { "word" word } }
{ $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." }
@@ -369,31 +261,6 @@ HELP: scan-word
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
-HELP: invalid-slot-name
-{ $values { "name" string } }
-{ $description "Throws an " { $link invalid-slot-name } " error." }
-{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
-{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
- { $code
- "TUPLE: my-mistaken-tuple slot-a slot-b"
- ""
- ": some-word ( a b c -- ) ... ;"
- }
-} ;
-
-HELP: unexpected
-{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
-{ $description "Throws an " { $link unexpected } " error." }
-{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
-{ $examples
- "Parsing the following snippet will throw this error:"
- { $code "[ 1 2 3 }" }
-} ;
-
-HELP: unexpected-eof
-{ $values { "word" "a " { $link word } } }
-{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ;
-
HELP: parse-step
{ $values { "accum" vector } { "end" word } { "?" "a boolean" } }
{ $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." }
@@ -417,28 +284,15 @@ HELP: parsed
{ $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." }
$parsing-note ;
-HELP: with-parser
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( -- accum )" } } { "newquot" "a new " { $link quotation } } }
-{ $description "Sets up the parser and calls the quotation. The quotation can make use of parsing words such as " { $link scan } " and " { $link parse-until } ". It must yield a sequence, which is converted to a quotation and output. Any errors thrown by the quotation are wrapped in parse errors." } ;
-
HELP: (parse-lines)
{ $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }
{ $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." }
-{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ;
+{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-lines
{ $values { "lines" "a sequence of strings" } { "quot" "a new " { $link quotation } } }
{ $description "Parses Factor source code which has been tokenized into lines. The vocabulary search path is taken from the current scope." }
-{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ;
-
-HELP: lexer-factory
-{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
-
-HELP: parse-effect
-{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
-{ $description "Parses a stack effect from the current input line." }
-{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
-$parsing-note ;
+{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } }
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 555c6eb32c..074b3738ac 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -198,7 +198,7 @@ IN: parser.tests
[
"IN: parser.tests : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
- ] [ parse-error? ] must-fail-with
+ ] [ source-file-error? ] must-fail-with
[ t ] [
"y" "parser.tests" lookup >boolean
@@ -298,12 +298,12 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
@@ -313,7 +313,7 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
@@ -323,7 +323,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> no-word-error? ] must-fail-with
+ ] [ error>> error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@@ -333,12 +333,12 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ error>> error>> no-word-error? ] must-fail-with
+ ] [ error>> error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ error>> error>> redefine-error? ] must-fail-with
+ ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
@@ -485,3 +485,9 @@ must-fail-with
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
+
+[
+ "IN: parser.tests : blah ; parsing FORGET: blah" eval
+] [
+ error>> staging-violation?
+] must-fail-with
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 129d5ef2ee..601245c463 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -4,38 +4,17 @@ USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.streams.string vocabs
-io.encodings.utf8 source-files classes classes.tuple hashtables
-compiler.errors compiler.units accessors sets ;
+io.encodings.utf8 source-files classes hashtables
+compiler.errors compiler.units accessors sets lexer ;
IN: parser
-TUPLE: lexer text line line-text line-length column ;
-
-: next-line ( lexer -- )
- dup [ line>> ] [ text>> ] bi ?nth >>line-text
- dup line-text>> length >>line-length
- [ 1+ ] change-line
- 0 >>column
- drop ;
-
-: new-lexer ( text class -- lexer )
- new
- 0 >>line
- swap >>text
- dup next-line ; inline
-
-: <lexer> ( text -- lexer )
- lexer new-lexer ;
-
: location ( -- loc )
- file get lexer get lexer-line 2dup and
- [ >r source-file-path r> 2array ] [ 2drop f ] if ;
+ file get lexer get line>> 2dup and
+ [ >r path>> r> 2array ] [ 2drop f ] if ;
: save-location ( definition -- )
location remember-definition ;
-: save-class-location ( class -- )
- location remember-class ;
-
SYMBOL: parser-notes
t parser-notes set-global
@@ -43,161 +22,16 @@ t parser-notes set-global
: parser-notes? ( -- ? )
parser-notes get "quiet" get not and ;
-: file. ( file -- )
- [
- source-file-path <pathname> pprint
- ] [
- "<interactive>" write
- ] if* ":" write ;
-
: note. ( str -- )
parser-notes? [
- file get file.
- lexer get [
- lexer-line number>string print
- ] [
- nl
- ] if*
+ file get [ file. ] when*
+ lexer get line>> number>string write ": " write
"Note: " write dup print
] when drop ;
-: skip ( i seq ? -- n )
- over >r
- [ swap CHAR: \s eq? xor ] curry find-from drop
- [ r> drop ] [ r> length ] if* ;
-
-: change-lexer-column ( lexer quot -- )
- swap
- [ dup lexer-column swap lexer-line-text rot call ] keep
- set-lexer-column ; inline
-
-GENERIC: skip-blank ( lexer -- )
-
-M: lexer skip-blank ( lexer -- )
- [ t skip ] change-lexer-column ;
-
-GENERIC: skip-word ( lexer -- )
-
-M: lexer skip-word ( lexer -- )
- [
- 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
- ] change-lexer-column ;
-
-: still-parsing? ( lexer -- ? )
- dup lexer-line swap lexer-text length <= ;
-
-: still-parsing-line? ( lexer -- ? )
- dup lexer-column swap lexer-line-length < ;
-
-: (parse-token) ( lexer -- str )
- [ lexer-column ] keep
- [ skip-word ] keep
- [ lexer-column ] keep
- lexer-line-text subseq ;
-
-: parse-token ( lexer -- str/f )
- dup still-parsing? [
- dup skip-blank
- dup still-parsing-line?
- [ (parse-token) ] [ dup next-line parse-token ] if
- ] [ drop f ] if ;
-
-: scan ( -- str/f ) lexer get parse-token ;
-
-ERROR: bad-escape ;
-
-M: bad-escape summary drop "Bad escape code" ;
-
-: escape ( escape -- ch )
- H{
- { CHAR: a CHAR: \a }
- { CHAR: e CHAR: \e }
- { CHAR: n CHAR: \n }
- { CHAR: r CHAR: \r }
- { CHAR: t CHAR: \t }
- { CHAR: s CHAR: \s }
- { CHAR: \s CHAR: \s }
- { CHAR: 0 CHAR: \0 }
- { CHAR: \\ CHAR: \\ }
- { CHAR: \" CHAR: \" }
- } at [ bad-escape ] unless* ;
-
-SYMBOL: name>char-hook
-
-name>char-hook global [
- [ "Unicode support not available" throw ] or
-] change-at
-
-: unicode-escape ( str -- ch str' )
- "{" ?head-slice [
- CHAR: } over index cut-slice
- >r >string name>char-hook get call r>
- rest-slice
- ] [
- 6 cut-slice >r hex> r>
- ] if ;
-
-: next-escape ( str -- ch str' )
- "u" ?head-slice [
- unicode-escape
- ] [
- unclip-slice escape swap
- ] if ;
-
-: (parse-string) ( str -- m )
- dup [ "\"\\" member? ] find dup [
- >r cut-slice >r % r> rest-slice r>
- dup CHAR: " = [
- drop slice-from
- ] [
- drop next-escape >r , r> (parse-string)
- ] if
- ] [
- "Unterminated string" throw
- ] if ;
-
-: parse-string ( -- str )
- lexer get [
- [ swap tail-slice (parse-string) ] "" make swap
- ] change-lexer-column ;
-
-TUPLE: parse-error file line column line-text error ;
-
-: <parse-error> ( msg -- error )
- \ parse-error new
- file get >>file
- lexer get line>> >>line
- lexer get column>> >>column
- lexer get line-text>> >>line-text
- swap >>error ;
-
-: parse-dump ( error -- )
- {
- [ file>> file. ]
- [ line>> number>string print ]
- [ line-text>> dup string? [ print ] [ drop ] if ]
- [ column>> 0 or CHAR: \s <string> write ]
- } cleave
- "^" print ;
-
-M: parse-error error.
- [ parse-dump ] [ error>> error. ] bi ;
-
-M: parse-error summary
- error>> summary ;
-
-M: parse-error compute-restarts
- error>> compute-restarts ;
-
-M: parse-error error-help
- error>> error-help ;
-
SYMBOL: use
SYMBOL: in
-: word/vocab% ( word -- )
- "(" % dup word-vocabulary % " " % word-name % ")" % ;
-
: (use+) ( vocab -- )
vocab-words use get push ;
@@ -216,25 +50,8 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-ERROR: unexpected want got ;
-
-PREDICATE: unexpected-eof < unexpected
- unexpected-got not ;
-
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
-: unexpected-eof ( word -- * ) f unexpected ;
-
-: (parse-tokens) ( accum end -- accum )
- scan 2dup = [
- 2drop
- ] [
- [ pick push (parse-tokens) ] [ unexpected-eof ] if*
- ] if ;
-
-: parse-tokens ( end -- seq )
- 100 <vector> swap (parse-tokens) >array ;
-
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
@@ -248,18 +65,8 @@ M: no-current-vocab summary ( obj -- )
: CREATE ( -- word ) scan create-in ;
-: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
-
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-: create-class-in ( word -- word )
- current-vocab create
- dup save-class-location
- dup predicate-word dup set-word save-location ;
-
-: CREATE-CLASS ( -- word )
- scan create-class-in ;
-
: word-restarts ( possibilities -- restarts )
natural-sort [
[ "Use the word " swap summary append ] keep
@@ -296,62 +103,6 @@ M: no-word-error summary
] ?if
] when ;
-: create-method-in ( class generic -- method )
- create-method f set-word dup save-location ;
-
-: CREATE-METHOD ( -- method )
- scan-word bootstrap-word scan-word create-method-in ;
-
-: shadowed-slots ( superclass slots -- shadowed )
- >r all-slot-names r> intersect ;
-
-: check-slot-shadowing ( class superclass slots -- )
- shadowed-slots [
- [
- "Definition of slot ``" %
- %
- "'' in class ``" %
- word-name %
- "'' shadows a superclass slot" %
- ] "" make note.
- ] with each ;
-
-ERROR: invalid-slot-name name ;
-
-M: invalid-slot-name summary
- drop
- "Invalid slot name" ;
-
-: (parse-tuple-slots) ( -- )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
- scan {
- { [ dup not ] [ unexpected-eof ] }
- { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop ] }
- [ , (parse-tuple-slots) ]
- } cond ;
-
-: parse-tuple-slots ( -- seq )
- [ (parse-tuple-slots) ] { } make ;
-
-: parse-tuple-definition ( -- class superclass slots )
- CREATE-CLASS
- scan {
- { ";" [ tuple f ] }
- { "<" [ scan-word parse-tuple-slots ] }
- [ >r tuple parse-tuple-slots r> prefix ]
- } case 3dup check-slot-shadowing ;
-
-ERROR: not-in-a-method-error ;
-
-M: not-in-a-method-error summary
- drop "call-next-method can only be called in a method definition" ;
-
ERROR: staging-violation word ;
M: staging-violation summary
@@ -362,6 +113,10 @@ M: staging-violation summary
dup changed-definitions get key? [ staging-violation ] when
execute ;
+: scan-object ( -- object )
+ scan-word dup parsing-word?
+ [ V{ } clone swap execute-parsing first ] when ;
+
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
@@ -379,37 +134,12 @@ M: staging-violation summary
: parsed ( accum obj -- accum ) over push ;
-: with-parser ( lexer quot -- newquot )
- swap lexer set
- [ call >quotation ] [ <parse-error> rethrow ] recover ;
-
: (parse-lines) ( lexer -- quot )
- [ f parse-until ] with-parser ;
-
-SYMBOL: lexer-factory
-
-[ <lexer> ] lexer-factory set-global
+ [ f parse-until >quotation ] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
-! Parsing word utilities
-: parse-effect ( end -- effect )
- parse-tokens dup { "(" "((" } intersect empty? [
- { "--" } split1 dup [
- <effect>
- ] [
- "Stack effect declaration must contain --" throw
- ] if
- ] [
- "Stack effect declaration must not contain ( or ((" throw
- ] if ;
-
-ERROR: bad-number ;
-
-: parse-base ( parsed base -- parsed )
- scan swap base> [ bad-number ] unless* parsed ;
-
: parse-literal ( accum end quot -- accum )
>r parse-until r> call parsed ; inline
@@ -418,40 +148,14 @@ ERROR: bad-number ;
: (:) ( -- word def ) CREATE-WORD parse-definition ;
-SYMBOL: current-class
-SYMBOL: current-generic
-
-: with-method-definition ( quot -- parsed )
- [
- >r
- [ "method-class" word-prop current-class set ]
- [ "method-generic" word-prop current-generic set ]
- [ ] tri
- r> call
- ] with-scope ; inline
-
-: (M:) ( method def -- )
- CREATE-METHOD [ parse-definition ] with-method-definition ;
-
-: scan-object ( -- object )
- scan-word dup parsing-word?
- [ V{ } clone swap execute first ] when ;
-
-GENERIC: expected>string ( obj -- str )
-
-M: f expected>string drop "end of input" ;
-M: word expected>string word-name ;
-M: string expected>string ;
-
-M: unexpected error.
- "Expected " write
- dup unexpected-want expected>string write
- " but got " write
- unexpected-got expected>string print ;
+ERROR: bad-number ;
M: bad-number summary
drop "Bad number literal" ;
+: parse-base ( parsed base -- parsed )
+ scan swap base> [ bad-number ] unless* parsed ;
+
SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index d5f4dd5906..9e11611f5b 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -167,9 +167,11 @@ unit-test
"another-retain-layout" another-retain-layout-test check-see
] unit-test
+DEFER: parse-error-file
+
: another-soft-break-test
{
- "USING: namespaces parser sequences ;"
+ "USING: namespaces sequences ;"
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
@@ -183,7 +185,7 @@ unit-test
: string-layout
{
- "USING: io kernel parser ;"
+ "USING: io kernel lexer ;"
"IN: prettyprint.tests"
": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write"
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 02a7191f0a..2d05d3c2ef 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -206,6 +206,8 @@ M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
M: slice length dup slice-to swap slice-from - ;
+: short ( seq n -- seq n' ) over length min ; inline
+
: head-slice ( seq n -- slice ) (head) <slice> ;
: tail-slice ( seq n -- slice ) (tail) <slice> ;
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 454f148974..2c5c19708e 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -75,11 +75,35 @@ M: pathname forget*
SYMBOL: file
+TUPLE: source-file-error file error ;
+
+: <source-file-error> ( msg -- error )
+ \ source-file-error new
+ file get >>file
+ swap >>error ;
+
+: file. ( file -- ) path>> <pathname> . ;
+
+M: source-file-error error.
+ [ file>> file. ] [ error>> error. ] bi ;
+
+M: source-file-error summary
+ error>> summary ;
+
+M: source-file-error compute-restarts
+ error>> compute-restarts ;
+
+M: source-file-error error-help
+ error>> error-help ;
+
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
swap source-file
dup file set
source-file-definitions old-definitions set
- [ ] [ file get rollback-source-file ] cleanup
+ [
+ file get rollback-source-file
+ <source-file-error> rethrow
+ ] recover
] with-scope ; inline
diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor
new file mode 100644
index 0000000000..e1c53cd87a
--- /dev/null
+++ b/core/strings/parser/parser-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax strings lexer ;
+IN: strings.parser
+
+HELP: bad-escape
+{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ;
+
+HELP: escape
+{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
+{ $description "Converts from a single-character escape code and the corresponding character." }
+{ $examples { $example "USING: kernel prettyprint strings.parser ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
+
+HELP: parse-string
+{ $values { "str" "a new " { $link string } } }
+{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
+{ $errors "Throws an error if the string contains an invalid escape sequence." }
+$parsing-note ;
diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor
new file mode 100644
index 0000000000..08421b4a20
--- /dev/null
+++ b/core/strings/parser/parser.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel inspector assocs namespaces splitting sequences
+strings math.parser lexer ;
+IN: strings.parser
+
+ERROR: bad-escape ;
+
+M: bad-escape summary drop "Bad escape code" ;
+
+: escape ( escape -- ch )
+ H{
+ { CHAR: a CHAR: \a }
+ { CHAR: e CHAR: \e }
+ { CHAR: n CHAR: \n }
+ { CHAR: r CHAR: \r }
+ { CHAR: t CHAR: \t }
+ { CHAR: s CHAR: \s }
+ { CHAR: \s CHAR: \s }
+ { CHAR: 0 CHAR: \0 }
+ { CHAR: \\ CHAR: \\ }
+ { CHAR: \" CHAR: \" }
+ } at [ bad-escape ] unless* ;
+
+SYMBOL: name>char-hook
+
+name>char-hook global [
+ [ "Unicode support not available" throw ] or
+] change-at
+
+: unicode-escape ( str -- ch str' )
+ "{" ?head-slice [
+ CHAR: } over index cut-slice
+ >r >string name>char-hook get call r>
+ rest-slice
+ ] [
+ 6 cut-slice >r hex> r>
+ ] if ;
+
+: next-escape ( str -- ch str' )
+ "u" ?head-slice [
+ unicode-escape
+ ] [
+ unclip-slice escape swap
+ ] if ;
+
+: (parse-string) ( str -- m )
+ dup [ "\"\\" member? ] find dup [
+ >r cut-slice >r % r> rest-slice r>
+ dup CHAR: " = [
+ drop slice-from
+ ] [
+ drop next-escape >r , r> (parse-string)
+ ] if
+ ] [
+ "Unterminated string" throw
+ ] if ;
+
+: parse-string ( -- str )
+ lexer get [
+ [ swap tail-slice (parse-string) ] "" make swap
+ ] change-lexer-column ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 91a453408d..4d4b81d00e 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,13 +1,14 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays byte-vectors
-definitions generic hashtables kernel math
-namespaces parser sequences strings sbufs vectors words
-quotations io assocs splitting classes.tuple generic.standard
-generic.math classes io.files vocabs float-arrays
-classes.union classes.intersection classes.mixin
-classes.predicate classes.singleton compiler.units
-combinators debugger ;
+definitions generic hashtables kernel math namespaces parser
+lexer sequences strings strings.parser sbufs vectors
+words quotations io assocs splitting classes.tuple
+generic.standard generic.math generic.parser classes io.files
+vocabs float-arrays classes.parser classes.union
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple.parser compiler.units
+combinators debugger effects.parser ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -167,7 +168,7 @@ IN: bootstrap.syntax
"C:" [
CREATE-WORD
- scan-word dup check-tuple
+ scan-word check-tuple-class
[ boa ] curry define-inline
] define-syntax
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 45b0d6b019..5ed0b0a34c 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ error>> error>> no-word-error? ] must-fail-with
+] [ error>> error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor
index 7d3ef89759..c83d4b5152 100644
--- a/extra/bitfields/bitfields.factor
+++ b/extra/bitfields/bitfields.factor
@@ -1,4 +1,4 @@
-USING: parser kernel math sequences namespaces assocs inspector
+USING: parser lexer kernel math sequences namespaces assocs inspector
words splitting math.parser arrays sequences.next mirrors
shuffle compiler.units ;
IN: bitfields
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 4151b44cfb..e6c97b90dd 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -1,5 +1,5 @@
-USING: kernel namespaces
+USING: combinators.short-circuit kernel namespaces
math
math.constants
math.functions
diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor
index a1feac381d..e3c54e0744 100755
--- a/extra/boids/ui/ui.factor
+++ b/extra/boids/ui/ui.factor
@@ -1,5 +1,5 @@
-USING: kernel namespaces
+USING: combinators.short-circuit kernel namespaces
math
math.functions
math.vectors
@@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
- "" <label> dup reverse-video-theme >population-label update-population-label
+ "" <label> reverse-video-theme >population-label update-population-label
- "" <label> dup reverse-video-theme >cohesion-label update-cohesion-label
- "" <label> dup reverse-video-theme >alignment-label update-alignment-label
- "" <label> dup reverse-video-theme >separation-label update-separation-label
+ "" <label> reverse-video-theme >cohesion-label update-cohesion-label
+ "" <label> reverse-video-theme >alignment-label update-alignment-label
+ "" <label> reverse-video-theme >separation-label update-separation-label
<frame>
diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor
index 0476cbf18b..b46e322d7b 100755
--- a/extra/bootstrap/unicode/unicode.factor
+++ b/extra/bootstrap/unicode/unicode.factor
@@ -1,4 +1,4 @@
-USING: parser kernel namespaces ;
+USING: strings.parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case
diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor
index 643737b23c..22e97b455e 100755
--- a/extra/bunny/deploy.factor
+++ b/extra/bunny/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-reflection 2 }
+ { deploy-io 3 }
+ { deploy-c-types? f }
{ deploy-random? f }
+ { deploy-ui? t }
{ deploy-name "Bunny" }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-compiler? t }
- { deploy-math? t }
- { deploy-c-types? f }
- { deploy-io 3 }
- { deploy-reflection 1 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-props? f }
}
diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index f4cfb20591..1dd1e0a264 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
-core-foundation namespaces assocs hashtables compiler.units ;
+core-foundation namespaces assocs hashtables compiler.units
+lexer ;
IN: cocoa
: (remember-send) ( selector variable -- )
diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor
index 78916bb027..e511e88fcc 100755
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@@ -10,9 +10,6 @@ IN: combinators.lib.tests
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
-[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
-[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
-[ [ sq ] 3apply ] must-infer
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
@@ -23,35 +20,6 @@ IN: combinators.lib.tests
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
] unit-test
-! &&
-
-[ t ] [
- 3 {
- [ dup number? ] [ dup odd? ] [ dup 0 > ]
- } 0&& nip
-] unit-test
-
-[ f ] [
- 3 {
- [ dup number? ] [ dup even? ] [ dup 0 > ]
- } 0&& nip
-] unit-test
-
-! ||
-
-[ t ] [
- 4 {
- [ dup array? ] [ dup number? ] [ 3 throw ]
- } 0|| nip
-] unit-test
-
-[ f ] [
- 4 {
- [ dup array? ] [ dup vector? ] [ dup float? ]
- } 0|| nip
-] unit-test
-
-
{ 1 1 } [
[ even? ] [ drop 1 ] [ drop 2 ] ifte
] must-infer-as
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index fe6b68638b..3fab4f62ae 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -36,8 +36,6 @@ MACRO: napply ( n -- )
'[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
-: 3apply ( obj obj obj quot -- ) 3 napply ; inline
-
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
@@ -59,47 +57,6 @@ MACRO: napply ( n -- )
: assoc-map-with ( obj assoc quot -- assoc )
with* assoc-map ; inline
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! short circuiting words
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: short-circuit ( quots quot default -- quot )
- 1quotation -rot { } map>assoc <reversed> alist>quot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 0&& ( quots -- quot )
- [ '[ drop @ dup not ] [ drop f ] 2array ] map
- { [ t ] [ ] } suffix
- '[ f , cond ] ;
-
-MACRO: 1&& ( quots -- quot )
- [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
- { [ t ] [ nip ] } suffix
- '[ f , cond ] ;
-
-MACRO: 2&& ( quots -- quot )
- [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
- { [ t ] [ 2nip ] } suffix
- '[ f , cond ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 0|| ( quots -- quot )
- [ '[ drop @ dup ] [ ] 2array ] map
- { [ drop t ] [ f ] } suffix
- '[ f , cond ] ;
-
-MACRO: 1|| ( quots -- quot )
- [ '[ drop dup @ dup ] [ nip ] 2array ] map
- { [ drop drop t ] [ f ] } suffix
- '[ f , cond ] ;
-
-MACRO: 2|| ( quots -- quot )
- [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
- { [ drop 2drop t ] [ f ] } suffix
- '[ f , cond ] ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/combinators/short-circuit/short-circuit-tests.factor b/extra/combinators/short-circuit/short-circuit-tests.factor
new file mode 100644
index 0000000000..e392d67d2a
--- /dev/null
+++ b/extra/combinators/short-circuit/short-circuit-tests.factor
@@ -0,0 +1,32 @@
+
+USING: kernel math tools.test combinators.short-circuit ;
+
+IN: combinators.short-circuit.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t
+[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t
+[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
+
+[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f
+[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f
+[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
+
+[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t
+
+[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t
+
+[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor
new file mode 100644
index 0000000000..3301633d7d
--- /dev/null
+++ b/extra/combinators/short-circuit/short-circuit.factor
@@ -0,0 +1,33 @@
+
+USING: kernel combinators quotations arrays sequences assocs
+ locals shuffle macros fry ;
+
+IN: combinators.short-circuit
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: n&&-rewrite ( quots N -- quot )
+ quots
+ [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
+ map
+ [ t ] [ N nnip ] 2array suffix
+ '[ f , cond ] ;
+
+MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
+MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
+MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: n||-rewrite ( quots N -- quot )
+ quots
+ [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
+ map
+ [ drop N ndrop t ] [ f ] 2array suffix
+ '[ f , cond ] ;
+
+MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
+MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
+MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/combinators/short-circuit/smart/smart-tests.factor b/extra/combinators/short-circuit/smart/smart-tests.factor
new file mode 100644
index 0000000000..7ec4a0e657
--- /dev/null
+++ b/extra/combinators/short-circuit/smart/smart-tests.factor
@@ -0,0 +1,32 @@
+
+USING: kernel math tools.test combinators.short-circuit.smart ;
+
+IN: combinators.short-circuit.smart.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: must-be-t ( in -- ) [ t ] swap unit-test ;
+: must-be-f ( in -- ) [ f ] swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
+[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
+[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
+
+[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
+[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
+[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
+
+[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
+
+[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
+
+[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
diff --git a/extra/combinators/short-circuit/smart/smart.factor b/extra/combinators/short-circuit/smart/smart.factor
new file mode 100644
index 0000000000..2cef957a6f
--- /dev/null
+++ b/extra/combinators/short-circuit/smart/smart.factor
@@ -0,0 +1,11 @@
+
+USING: kernel sequences math inference accessors macros
+ combinators.short-circuit ;
+
+IN: combinators.short-circuit.smart
+
+MACRO: && ( quots -- quot )
+ dup first infer [ in>> ] [ out>> ] bi - 1+ n&&-rewrite ;
+
+MACRO: || ( quots -- quot )
+ dup first infer [ in>> ] [ out>> ] bi - 1+ n||-rewrite ;
diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor
index dc20e7ad5c..528e1956b8 100755
--- a/extra/concurrency/distributed/distributed-tests.factor
+++ b/extra/concurrency/distributed/distributed-tests.factor
@@ -13,8 +13,6 @@ concurrency.messaging continuations accessors prettyprint ;
[ ] [ test-node dup (start-node) ] unit-test
-[ ] [ 1000 sleep ] unit-test
-
[ ] [
[
receive first2 >r 3 + r> send
@@ -30,6 +28,4 @@ concurrency.messaging continuations accessors prettyprint ;
receive
] unit-test
-[ ] [ 1000 sleep ] unit-test
-
[ ] [ test-node stop-node ] unit-test
diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor
index 9ae2627505..4da079e812 100755
--- a/extra/concurrency/distributed/distributed.factor
+++ b/extra/concurrency/distributed/distributed.factor
@@ -12,16 +12,15 @@ SYMBOL: local-node
deserialize
[ first2 get-process send ] [ stop-server ] if* ;
+: <node-server> ( addrspec -- threaded-server )
+ <threaded-server>
+ swap >>insecure
+ binary >>encoding
+ "concurrency.distributed" >>name
+ [ handle-node-client ] >>handler ;
+
: (start-node) ( addrspec addrspec -- )
- local-node set-global
- [
- <threaded-server>
- swap >>insecure
- binary >>encoding
- "concurrency.distributed" >>name
- [ handle-node-client ] >>handler
- start-server
- ] curry "Distributed concurrency server" spawn drop ;
+ local-node set-global <node-server> start-server* ;
: start-node ( port -- )
host-name over <inet> (start-node) ;
diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor
index b0ffb6ae54..aa8dc4f9cf 100755
--- a/extra/cpu/8080/emulator/emulator.factor
+++ b/extra/cpu/8080/emulator/emulator.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel math sequences words arrays io io.files namespaces
-math.parser assocs quotations parser parser-combinators
+math.parser assocs quotations parser lexer parser-combinators
tools.time io.encodings.binary sequences.deep symbols combinators ;
IN: cpu.8080.emulator
diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor
index 039b969ddd..87f9821153 100644
--- a/extra/dns/forwarding/forwarding.factor
+++ b/extra/dns/forwarding/forwarding.factor
@@ -1,5 +1,5 @@
-USING: kernel
+USING: combinators.short-circuit kernel
combinators
vectors
sequences
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index 04b3ecfbee..16677d8761 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -1,7 +1,7 @@
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
- combinators.cleave combinators.lib
+ combinators.cleave combinators.lib combinators.short-circuit
newfx fry
dns dns.util dns.misc ;
diff --git a/extra/editors/editors-docs.factor b/extra/editors/editors-docs.factor
index 2b9e4cc021..0f50e40eb4 100644
--- a/extra/editors/editors-docs.factor
+++ b/extra/editors/editors-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax parser vocabs.loader ;
+USING: help.markup help.syntax parser source-files vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
@@ -35,4 +35,4 @@ HELP: no-edit-hook
{ $error-description "Thrown when " { $link edit } " is called when the " { $link edit-hook } " variable is not set. See " { $link "editor" } "." } ;
HELP: :edit
-{ $description "If the most recent error was a " { $link parse-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ;
+{ $description "If the most recent error was a " { $link source-file-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ;
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index ec8313363e..78f6caf965 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tools.crossref tools.vocabs
-io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting accessors ;
+USING: parser lexer kernel namespaces sequences definitions
+io.files inspector continuations tools.crossref tools.vocabs io
+prettyprint source-files assocs vocabs vocabs.loader io.backend
+splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
@@ -35,21 +35,37 @@ SYMBOL: edit-hook
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
-GENERIC: find-parse-error ( error -- error' )
+GENERIC: error-file ( error -- file )
-M: parse-error find-parse-error
- dup error>> find-parse-error [ ] [ ] ?if ;
+GENERIC: error-line ( error -- line )
-M: condition find-parse-error
- error>> find-parse-error ;
+M: lexer-error error-file
+ error>> error-file ;
-M: object find-parse-error
+M: lexer-error error-line
+ [ error>> error-line ] [ line>> ] bi or ;
+
+M: source-file-error error-file
+ [ error>> error-file ] [ file>> path>> ] bi or ;
+
+M: source-file-error error-line
+ error>> error-line ;
+
+M: condition error-file
+ error>> error-file ;
+
+M: condition error-line
+ error>> error-line ;
+
+M: object error-file
+ drop f ;
+
+M: object error-line
drop f ;
: :edit ( -- )
- error get find-parse-error [
- [ file>> path>> ] [ line>> ] bi edit-location
- ] when* ;
+ error get [ error-file ] [ error-line ] bi
+ 2dup and [ edit-location ] [ 2drop ] if ;
: edit-each ( seq -- )
[
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index c71eadb72f..c5a5449b25 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io io.encodings.8-bit
+USING: combinators.short-circuit accessors combinators io io.encodings.8-bit
io.encodings io.encodings.binary io.encodings.utf8 io.files
io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor
index 49cf98e0e3..ae9458f4ac 100644
--- a/extra/furnace/auth/login/permits/permits.factor
+++ b/extra/furnace/auth/login/permits/permits.factor
@@ -1,6 +1,8 @@
USING: accessors namespaces combinators.lib kernel
db.tuples db.types
-furnace.auth furnace.sessions furnace.cache ;
+furnace.auth furnace.sessions furnace.cache
+combinators.short-circuit ;
+
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor
index 0e2a673d9b..2bb97e7c14 100644
--- a/extra/furnace/boilerplate/boilerplate.factor
+++ b/extra/furnace/boilerplate/boilerplate.factor
@@ -7,7 +7,7 @@ html.templates.chloe
locals
http.server
http.server.filters
-furnace ;
+furnace combinators.short-circuit ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ;
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index 6e50417ea1..0ec9648a67 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -7,7 +7,7 @@ io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
-furnace furnace.cache ;
+furnace furnace.cache combinators.short-circuit ;
IN: furnace.sessions
TUPLE: session < server-state namespace user-agent client changed? ;
diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor
index b9de7c1b74..ba0ff5bedd 100644
--- a/extra/gesture-logger/gesture-logger.factor
+++ b/extra/gesture-logger/gesture-logger.factor
@@ -1,16 +1,17 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel prettyprint ui ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors ;
+ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors
+accessors ;
IN: gesture-logger
TUPLE: gesture-logger stream ;
: <gesture-logger> ( stream -- gadget )
\ gesture-logger construct-gadget
- [ set-gesture-logger-stream ] keep
- { 100 100 } over set-rect-dim
- dup black solid-interior ;
+ swap >>stream
+ { 100 100 } >>dim
+ black solid-interior ;
M: gesture-logger handle-gesture*
drop
diff --git a/extra/graph-theory/authors.txt b/extra/graph-theory/authors.txt
new file mode 100644
index 0000000000..93667236de
--- /dev/null
+++ b/extra/graph-theory/authors.txt
@@ -0,0 +1 @@
+William Schlieper
diff --git a/extra/graph-theory/graph-theory-docs.factor b/extra/graph-theory/graph-theory-docs.factor
new file mode 100644
index 0000000000..82d8b9adf6
--- /dev/null
+++ b/extra/graph-theory/graph-theory-docs.factor
@@ -0,0 +1,135 @@
+! See http://factorcode.org/license.txt for BSD licence.
+USING: help.markup help.syntax ;
+
+IN: graph-theory
+
+ARTICLE: "graph-protocol" "Graph protocol"
+"All graphs must be instances of the graph mixin:"
+{ $subsection graph }
+"All graphs must implement a method on the following generic word:"
+{ $subsection vertices }
+"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
+{ $subsection adjlist }
+{ $subsection adj? }
+"All mutable graphs must implement a method on the following generic word:"
+{ $subsection add-blank-vertex }
+"All mutable undirected graphs must implement a method on the following generic word:"
+{ $subsection add-edge }
+"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
+{ $subsection add-edge* }
+"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
+{ $subsection num-vertices }
+{ $subsection num-edges } ;
+
+HELP: graph
+{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
+ { $code "INSTANCE: hex-board graph" }
+} ;
+
+{ vertices num-vertices num-edges } related-words
+
+HELP: vertices
+{ $values { "graph" graph } { "seq" "The vertices" } }
+{ $description "Returns the vertices of the graph." } ;
+
+HELP: num-vertices
+{ $values { "graph" graph } { "n" "The number of vertices" } }
+{ $description "Returns the number of vertices in the graph." } ;
+
+HELP: num-edges
+{ $values { "graph" "A graph" } { "n" "The number of edges" } }
+{ $description "Returns the number of edges in the graph." } ;
+
+{ adjlist adj? } related-words
+
+HELP: adjlist
+{ $values
+ { "from" "The index of a vertex" }
+ { "graph" "The graph to be examined" }
+ { "seq" "The adjacency list" } }
+{ $description "Returns a sequence of vertices that this vertex links to" } ;
+
+HELP: adj?
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of a vertex" }
+ { "graph" "A graph" }
+ { "?" "A boolean" } }
+{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
+
+{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
+
+HELP: add-blank-vertex
+{ $values
+ { "index" "A vertex index" }
+ { "graph" "A graph" } }
+{ $description "Adds a vertex to the graph." } ;
+
+HELP: add-blank-vertices
+{ $values
+ { "seq" "A sequence of vertex indices" }
+ { "graph" "A graph" } }
+{ $description "Adds vertices with indices in seq to the graph." } ;
+
+HELP: add-edge*
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a one-way edge to the graph, between from and to."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "m" "The index of a vertex" }
+ { "n" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between m and n."
+ $nl
+ "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
+
+{ depth-first full-depth-first dag? topological-sort } related-words
+
+HELP: depth-first
+{ $values
+ { "v" "The vertex to start the search at" }
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "?list" "A list of booleans describing the vertices visited in the search" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
+
+HELP: full-depth-first
+{ $values
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "tail" "A quotation of the form ( -- )" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
+
+HELP: dag?
+{ $values
+ { "graph" graph }
+ { "?" "A boolean indicating if the graph is acyclic" } }
+{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
+
+HELP: topological-sort
+{ $values
+ { "graph" graph }
+ { "seq/f" "Either a sequence of values or f" } }
+{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
diff --git a/extra/graph-theory/graph-theory.factor b/extra/graph-theory/graph-theory.factor
new file mode 100644
index 0000000000..322f17d2dd
--- /dev/null
+++ b/extra/graph-theory/graph-theory.factor
@@ -0,0 +1,92 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
+
+IN: graph-theory
+
+MIXIN: graph
+SYMBOL: visited?
+ERROR: end-search ;
+
+GENERIC: vertices ( graph -- seq ) flushable
+
+GENERIC: num-vertices ( graph -- n ) flushable
+
+GENERIC: num-edges ( graph -- n ) flushable
+
+GENERIC: adjlist ( from graph -- seq ) flushable
+
+GENERIC: adj? ( from to graph -- ? ) flushable
+
+GENERIC: add-blank-vertex ( index graph -- )
+
+GENERIC: delete-blank-vertex ( index graph -- )
+
+GENERIC: add-edge* ( from to graph -- )
+
+GENERIC: add-edge ( u v graph -- )
+
+GENERIC: delete-edge* ( from to graph -- )
+
+GENERIC: delete-edge ( u v graph -- )
+
+M: graph num-vertices
+ vertices length ;
+
+M: graph num-edges
+ [ vertices ] [ '[ , adjlist length ] map sum ] bi ;
+
+M: graph adjlist
+ [ vertices ] [ swapd '[ , swap , adj? ] filter ] bi ;
+
+M: graph adj?
+ swapd adjlist index >boolean ;
+
+M: graph add-edge
+ [ add-edge* ] [ swapd add-edge* ] 3bi ;
+
+M: graph delete-edge
+ [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
+
+: add-blank-vertices ( seq graph -- )
+ '[ , add-blank-vertex ] each ;
+
+: delete-vertex ( index graph -- )
+ [ adjlist ]
+ [ '[ , , 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ delete-blank-vertex ] 2tri ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
+ [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
+
+: (depth-first) ( v pre post -- )
+ { [ 2drop visited? get t -rot set-at ]
+ [ drop call ]
+ [ [ graph get adjlist ] 2dip
+ '[ dup visited? get at [ drop ] [ , , (depth-first) ] if ] each ]
+ [ nip call ] } 3cleave ; inline
+
+PRIVATE>
+
+: depth-first ( v graph pre post -- ?list ? )
+ '[ , , (depth-first) visited? get ] swap search-wrap ; inline
+
+: full-depth-first ( graph pre post tail -- ? )
+ '[ [ visited? get [ nip not ] assoc-find ]
+ [ drop , , (depth-first) @ ]
+ [ 2drop ] while ] swap search-wrap ; inline
+
+: dag? ( graph -- ? )
+ V{ } clone swap [ 2dup swap push dupd
+ '[ , swap graph get adj? not ] all?
+ [ end-search ] unless ]
+ [ drop dup pop* ] [ ] full-depth-first nip ;
+
+: topological-sort ( graph -- seq/f )
+ dup dag?
+ [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
diff --git a/extra/graph-theory/reversals/reversals.factor b/extra/graph-theory/reversals/reversals.factor
new file mode 100644
index 0000000000..1ea1a3fbf5
--- /dev/null
+++ b/extra/graph-theory/reversals/reversals.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel graph-theory ;
+
+IN: graph-theory.reversals
+
+TUPLE: reversal graph ;
+
+GENERIC: reverse-graph ( graph -- reversal )
+
+M: graph reverse-graph reversal boa ;
+
+M: reversal reverse-graph graph>> ;
+
+INSTANCE: reversal graph
+
+M: reversal vertices
+ graph>> vertices ;
+
+M: reversal adj?
+ swapd graph>> adj? ;
diff --git a/extra/graph-theory/sparse/sparse.factor b/extra/graph-theory/sparse/sparse.factor
new file mode 100644
index 0000000000..33c5505f0a
--- /dev/null
+++ b/extra/graph-theory/sparse/sparse.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
+
+IN: graph-theory.sparse
+
+TUPLE: sparse-graph alist ;
+
+: <sparse-graph> ( -- sparse-graph )
+ H{ } clone sparse-graph boa ;
+
+: >sparse-graph ( graph -- sparse-graph )
+ [ vertices ] keep
+ '[ dup , adjlist 2array ] map >hashtable sparse-graph boa ;
+
+INSTANCE: sparse-graph graph
+
+M: sparse-graph vertices
+ alist>> keys ;
+
+M: sparse-graph adjlist
+ alist>> at ;
+
+M: sparse-graph add-blank-vertex
+ alist>> V{ } clone -rot set-at ;
+
+M: sparse-graph delete-blank-vertex
+ alist>> delete-at ;
+
+M: sparse-graph add-edge*
+ alist>> swapd at adjoin ;
+
+M: sparse-graph delete-edge*
+ alist>> swapd at delete ;
diff --git a/extra/graph-theory/summary.txt b/extra/graph-theory/summary.txt
new file mode 100644
index 0000000000..3e1d791ab1
--- /dev/null
+++ b/extra/graph-theory/summary.txt
@@ -0,0 +1 @@
+Graph-theoretic algorithms
diff --git a/extra/graph-theory/tags.txt b/extra/graph-theory/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/extra/graph-theory/tags.txt
@@ -0,0 +1 @@
+collections
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index dfbb7a12b8..246ad56e51 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations io.streams.byte-array io.encodings.string
-classes.builtin parser ;
+classes.builtin parser lexer ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 32e4084150..150a66ec92 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -290,6 +290,11 @@ M: string ($instance)
: $values-x/y ( children -- )
drop { { "x" number } { "y" number } } $values ;
+: $parsing-note ( children -- )
+ drop
+ "This word should only be called from parsing words."
+ $notes ;
+
: $io-error ( children -- )
drop
"Throws an error if the I/O operation fails." $errors ;
diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor
index 7eeb756a39..cfa576d56f 100644
--- a/extra/html/templates/chloe/syntax/syntax.factor
+++ b/extra/html/templates/chloe/syntax/syntax.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
-classes.tuple assocs splitting words arrays memoize parser
+classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
diff --git a/extra/html/templates/fhtml/fhtml.factor b/extra/html/templates/fhtml/fhtml.factor
index 74e5c37ef1..e435fdce5f 100755
--- a/extra/html/templates/fhtml/fhtml.factor
+++ b/extra/html/templates/fhtml/fhtml.factor
@@ -4,7 +4,7 @@
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting
accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8
+parser lexer io io.files io.streams.string io.encodings.utf8
html.elements
html.templates ;
IN: html.templates.fhtml
@@ -55,8 +55,8 @@ DEFER: <% delimiter
: parse-template-lines ( lines -- quot )
<template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
+ V{ } clone lexer get parse-%> f (parse-until) >quotation
+ ] with-lexer ;
: parse-template ( string -- quot )
[
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 522d0c1845..7ddf6cf3aa 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -1,10 +1,16 @@
-USING: http tools.test multiline tuple-syntax
-io.streams.string io.encodings.utf8 io.encodings.string
-kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls hashtables
-accessors ;
+USING: http tools.test multiline tuple-syntax io.streams.string
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary
+io.encodings.string kernel arrays splitting sequences assocs
+io.sockets db db.sqlite continuations urls hashtables accessors
+;
IN: http.tests
+[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
+
+[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test
+
+[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
+
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
@@ -184,6 +190,13 @@ test-db [
init-furnace-tables
] with-db
+: test-httpd ( -- )
+ #! Return as soon as server is running.
+ <http-server>
+ 1237 >>insecure
+ f >>secure
+ start-server* ;
+
[ ] [
[
<dispatcher>
@@ -196,15 +209,13 @@ test-db [
"redirect-loop" add-responder
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
[ t ] [
"resource:extra/http/test/foo.html" ascii file-contents
- "http://localhost:1237/nested/foo.html" http-get nip ascii decode =
+ "http://localhost:1237/nested/foo.html" http-get nip =
] unit-test
[ "http://localhost:1237/redirect-loop" http-get nip ]
@@ -229,12 +240,10 @@ test-db [
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
@@ -256,12 +265,10 @@ test-db [
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
@@ -287,12 +294,10 @@ SYMBOL: a
test-db <db-persistence>
main-responder set
- [ 1237 httpd ] "HTTPD test" spawn drop
+ test-httpd
] with-scope
] unit-test
-[ ] [ 100 sleep ] unit-test
-
3 a set-global
: test-a string>xml "input" tag-named "value" swap at ;
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 4001301cb1..d5712d5bab 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -211,7 +211,8 @@ TUPLE: post-data raw content content-type ;
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
- ";" split1 parse-content-type-attributes "charset" swap at ;
+ ";" split1 parse-content-type-attributes "charset" swap at
+ name>encoding over "text/" head? latin1 binary ? or ;
: read-request ( -- request )
<request>
@@ -310,7 +311,7 @@ M: response clone
dup "content-type" header [
parse-content-type
[ >>content-type ]
- [ name>encoding binary or >>content-charset ] bi*
+ [ >>content-charset ] bi*
] when* ;
: read-response ( -- response )
diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor
index 33bfa4b202..bc6e1148c3 100644
--- a/extra/http/parsers/parsers.factor
+++ b/extra/http/parsers/parsers.factor
@@ -1,4 +1,4 @@
-USING: math math.order math.parser kernel combinators.lib
+USING: combinators.short-circuit math math.order math.parser kernel combinators.lib
sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces ascii ;
IN: http.parsers
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index ef1f575972..43507046d6 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -2,7 +2,7 @@ USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
classes.tuple namespaces vectors bit-arrays byte-arrays strings
sbufs math.functions macros sequences.private combinators
-mirrors combinators.lib ;
+mirrors combinators.lib combinators.short-circuit ;
IN: inverse
TUPLE: fail ;
diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor
index 33d629b105..8f5e955998 100644
--- a/extra/io/encodings/8-bit/8-bit-docs.factor
+++ b/extra/io/encodings/8-bit/8-bit-docs.factor
@@ -24,20 +24,13 @@ ARTICLE: "io.encodings.8-bit" "8-bit encodings"
{ $subsection koi8-r }
{ $subsection windows-1252 }
{ $subsection ebcdic }
-{ $subsection mac-roman }
-"Words used in defining these"
-{ $subsection 8-bit }
-{ $subsection define-8-bit-encoding } ;
+{ $subsection mac-roman } ;
ABOUT: "io.encodings.8-bit"
HELP: 8-bit
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
-HELP: define-8-bit-encoding
-{ $values { "name" string } { "stream" "an input stream" } }
-{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
-
HELP: latin1
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
{ $see-also "encodings-introduction" } ;
diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor
index 71c57ef68c..16fe052867 100755
--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@@ -30,15 +30,12 @@ IN: io.encodings.8-bit
} ;
: encoding-file ( file-name -- stream )
- "resource:extra/io/encodings/8-bit/" ".TXT"
- swapd 3append ascii <file-reader> ;
-
-: tail-if ( seq n -- newseq )
- 2dup swap length <= [ tail ] [ drop ] if ;
+ "resource:extra/io/encodings/8-bit/" swap ".TXT"
+ 3append ascii <file-reader> ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map harvest
- [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
+ [ "\t" split 2 head [ 2 short tail hex> ] map ] map ;
: byte>ch ( assoc -- array )
256 replacement-char <array>
@@ -51,39 +48,40 @@ IN: io.encodings.8-bit
lines process-contents
[ byte>ch ] [ ch>byte ] bi ;
-TUPLE: 8-bit name decode encode ;
+SYMBOL: 8-bit-encodings
+
+TUPLE: 8-bit decode encode ;
: encode-8-bit ( char stream assoc -- )
- swapd at* [ encode-error ] unless swap stream-write1 ;
+ swap >r at*
+ [ r> stream-write1 ] [ r> drop encode-error ] if ; inline
-M: 8-bit encode-char
- encode>> encode-8-bit ;
+M: 8-bit encode-char encode>> encode-8-bit ;
: decode-8-bit ( stream array -- char/f )
- swap stream-read1 dup
- [ swap nth [ replacement-char ] unless* ]
- [ nip ] if ;
+ >r stream-read1 dup
+ [ r> nth [ replacement-char ] unless* ] [ r> 2drop f ] if ; inline
-M: 8-bit decode-char
- decode>> decode-8-bit ;
-
-: make-8-bit ( word byte>ch ch>byte -- )
- [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ;
-
-: define-8-bit-encoding ( name stream -- )
- >r in get create r> parse-file make-8-bit ;
+M: 8-bit decode-char decode>> decode-8-bit ;
PREDICATE: 8-bit-encoding < word
- word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ;
+ 8-bit-encodings get-global key? ;
-M: 8-bit-encoding <encoder> word-def first <encoder> ;
+M: 8-bit-encoding <encoder>
+ 8-bit-encodings get-global at <encoder> ;
-M: 8-bit-encoding <decoder> word-def first <decoder> ;
+M: 8-bit-encoding <decoder>
+ 8-bit-encodings get-global at <decoder> ;
PRIVATE>
[
- "io.encodings.8-bit" in [
- mappings [ encoding-file define-8-bit-encoding ] assoc-each
- ] with-variable
+ mappings [
+ [ "io.encodings.8-bit" create ]
+ [ encoding-file parse-file 8-bit boa ]
+ bi*
+ ] assoc-map
+ [ keys [ define-symbol ] each ]
+ [ 8-bit-encodings set-global ]
+ bi
] with-compilation-unit
diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor
index bb87d67917..84e0d684ac 100755
--- a/extra/io/servers/connection/connection-tests.factor
+++ b/extra/io/servers/connection/connection-tests.factor
@@ -29,18 +29,22 @@ concurrency.promises io.encodings.ascii io threads calendar ;
[ ] [ <promise> "p" set ] unit-test
+[ ] [
+ <threaded-server>
+ 5 >>max-connections
+ 1237 >>insecure
+ [ "Hello world." write stop-server ] >>handler
+ "server" set
+] unit-test
+
[ ] [
[
- <threaded-server>
- 5 >>max-connections
- 1237 >>insecure
- [ "Hello world." write stop-server ] >>handler
- start-server
+ "server" get start-server
t "p" get fulfill
] in-thread
] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ "server" get wait-for-server ] unit-test
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor
index b062322142..fa0e2f515d 100755
--- a/extra/io/servers/connection/connection.factor
+++ b/extra/io/servers/connection/connection.factor
@@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
-quotations combinators combinators.lib logging calendar assocs
+quotations combinators logging calendar assocs
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators
-concurrency.semaphores ;
+concurrency.semaphores concurrency.flags
+combinators.short-circuit ;
IN: io.servers.connection
TUPLE: threaded-server
@@ -18,7 +19,8 @@ max-connections
semaphore
timeout
encoding
-handler ;
+handler
+ready ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@@ -31,7 +33,8 @@ handler ;
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
- [ "No handler quotation" throw ] >>handler ; inline
+ [ "No handler quotation" throw ] >>handler
+ <flag> >>ready ; inline
: <threaded-server> ( -- threaded-server )
threaded-server new-threaded-server ;
@@ -86,11 +89,13 @@ M: threaded-server handle-client* handler>> call ;
if*
] [ accept-loop ] bi ; inline
-: start-accept-loop ( server -- )
+: started-accept-loop ( server -- )
+ threaded-server get
+ [ sockets>> push ] [ ready>> raise-flag ] bi ;
+
+: start-accept-loop ( addrspec -- )
threaded-server get encoding>> <server>
- [ threaded-server get sockets>> push ]
- [ [ accept-loop ] with-disposal ]
- bi ;
+ [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
\ start-accept-loop ERROR add-error-logging
@@ -115,6 +120,14 @@ PRIVATE>
] with-variable
] with-secure-context ;
+: wait-for-server ( threaded-server -- )
+ ready>> wait-for-flag ;
+
+: start-server* ( threaded-server -- )
+ [ [ start-server ] curry "Threaded server" spawn drop ]
+ [ wait-for-server ]
+ bi ;
+
: stop-server ( -- )
threaded-server get [ f ] change-sockets drop dispose-each ;
diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor
old mode 100644
new mode 100755
index 78de43d379..311127e333
--- a/extra/io/sockets/secure/secure-tests.factor
+++ b/extra/io/sockets/secure/secure-tests.factor
@@ -2,3 +2,11 @@ IN: io.sockets.secure.tests
USING: accessors kernel io.sockets io.sockets.secure tools.test ;
[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
+
+[ ] [
+ <secure-config>
+ "resource:extra/openssl/test/server.pem" >>key-file
+ "resource:extra/openssl/test/dh1024.pem" >>dh-file
+ "password" >>password
+ [ ] with-secure-context
+] unit-test
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 6787936f96..419509f124 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -4,13 +4,13 @@ USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
-combinators.lib io.ports destructors accessors
+io.ports destructors accessors
math.bitfields math.bitfields.lib ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r share-mode security-attributes-inherit r> r>
+ >r >r share-mode default-security-attributes r> r>
CreateFile-flags f CreateFile opened-file
] with-destructors ;
@@ -216,11 +216,11 @@ M: winnt link-info ( path -- info )
"FILETIME" <c-object>
"FILETIME" <c-object>
[ GetFileTime win32-error=0/f ] 3keep
- [ FILETIME>timestamp >local-time ] 3apply
+ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ;
: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
- [ timestamp>FILETIME ] 3apply
+ [ timestamp>FILETIME ] tri@
SetFileTime win32-error=0/f ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 1a7462f304..786275c736 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -3,7 +3,7 @@ continuations destructors io io.backend io.ports io.timeouts
io.windows io.windows.files libc kernel math namespaces
sequences threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files
-io.buffers qualified ascii combinators.lib system
+io.buffers qualified ascii system
accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index e8bdd8e4ec..2a39cea479 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -3,7 +3,7 @@ io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
kernel libc math threads system
alien.c-types alien.arrays alien.strings sequences combinators
-combinators.lib sequences.lib ascii splitting alien strings
+combinators.short-circuit ascii splitting alien strings
assocs namespaces io.files.private accessors ;
IN: io.windows.nt.files
@@ -22,21 +22,18 @@ M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
- { [ dup right-trim-separators
- { [ dup length 2 = ] [ dup second CHAR: : = ] } 0&& nip ] [
- t
- ] }
+ { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;
ERROR: not-absolute-path ;
: root-directory ( string -- string' )
- {
- [ dup length 2 >= ]
- [ dup second CHAR: : = ]
- [ dup first Letter? ]
- } 0&& [ 2 head ] [ not-absolute-path ] if ;
+ dup {
+ [ length 2 >= ]
+ [ second CHAR: : = ]
+ [ first Letter? ]
+ } 1&& [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 6c86b53049..ff11c456ca 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -46,7 +46,7 @@ IN: io.windows.nt.launcher
path normalize-path
access-mode
share-mode
- security-attributes-inherit
+ default-security-attributes
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
@@ -58,11 +58,8 @@ IN: io.windows.nt.launcher
redirect-file
dup 0 FILE_END set-file-pointer ;
-: set-inherit ( handle ? -- )
- >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
-
: redirect-handle ( handle access-mode create-mode -- handle )
- 2drop handle>> duplicate-handle dup t set-inherit ;
+ 2drop handle>> duplicate-handle ;
: redirect-stream ( stream access-mode create-mode -- handle )
>r >r underlying-handle handle>> r> r> redirect-handle ;
@@ -75,7 +72,8 @@ IN: io.windows.nt.launcher
{ [ pick appender? ] [ redirect-append ] }
{ [ pick win32-file? ] [ redirect-handle ] }
[ redirect-stream ]
- } cond ;
+ } cond
+ dup [ dup t set-inherit ] when ;
: redirect-stdout ( process args -- handle )
drop
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 8e59a4d555..d79af52c5e 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -12,6 +12,7 @@ USE: io.windows.nt.sockets
USE: io.windows.mmap
USE: io.windows.files
USE: io.backend
+USE: openssl
USE: system
winnt set-io-backend
diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
index 97c2e49627..dc0d7cf1e5 100755
--- a/extra/io/windows/nt/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -16,13 +16,13 @@ IN: io.windows.nt.pipes
4096
4096
0
- security-attributes-inherit
+ default-security-attributes
CreateNamedPipe opened-file ;
: open-other-end ( name -- handle )
GENERIC_WRITE
{ FILE_SHARE_READ FILE_SHARE_WRITE } flags
- security-attributes-inherit
+ default-security-attributes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
f
diff --git a/extra/io/windows/sockets/sockets.factor b/extra/io/windows/sockets/sockets.factor
index 359776d639..d9ab10d5e3 100755
--- a/extra/io/windows/sockets/sockets.factor
+++ b/extra/io/windows/sockets/sockets.factor
@@ -7,8 +7,7 @@ HOOK: WSASocket-flags io-backend ( -- DWORD )
TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
- win32-socket new
- swap >>handle ;
+ win32-socket new-win32-handle ;
M: win32-socket dispose ( stream -- )
handle>> closesocket drop ;
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 5e10389c44..0892563a02 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -8,10 +8,13 @@ windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
IN: io.windows
+: set-inherit ( handle ? -- )
+ >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
+
TUPLE: win32-handle handle disposed ;
: new-win32-handle ( handle class -- win32-handle )
- new swap >>handle ;
+ new swap [ >>handle ] [ f set-inherit ] bi ;
: <win32-handle> ( handle -- win32-handle )
win32-handle new-win32-handle ;
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index 4b0fb53f5e..2fa0b6cc71 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -1,5 +1,6 @@
USING: sequences kernel math locals math.order math.ranges
-accessors combinators.lib arrays namespaces combinators ;
+accessors combinators.lib arrays namespaces combinators
+combinators.short-circuit ;
IN: lcs
<PRIVATE
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e3d942d390..109083de37 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -3,7 +3,7 @@
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
-quotations fry lists inspector ;
+quotations fry lists inspector combinators.short-circuit ;
IN: lisp
DEFER: convert-form
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 8fadb00e65..428e1221da 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
-combinators.lib math fry accessors lists ;
+combinators.lib math fry accessors lists combinators.short-circuit ;
IN: lisp.parser
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index 4e670cdac0..025e175bc2 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -1,6 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
-accessors ;
+accessors generic ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@@ -265,3 +265,14 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
[ \ a-word-with-locals see ] with-string-writer
new-definition =
] unit-test
+
+: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
+
+GENERIC: method-with-locals ( x -- y )
+
+M:: sequence method-with-locals ( a -- y ) a reverse ;
+
+[ t ] [
+ [ \ sequence \ method-with-locals method see ] with-string-writer
+ method-definition =
+] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 028502560f..49eec6d652 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -4,8 +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 prettyprint.sections sets
-sequences.private effects generic compiler.units accessors
-locals.backend memoize ;
+sequences.private effects effects.parser generic generic.parser
+compiler.units accessors locals.backend memoize lexer ;
IN: locals
! Inspired by
@@ -405,8 +405,8 @@ M: lambda-memoized reset-word
M: lambda-method synopsis*
dup dup dup definer.
- "method-specializer" word-prop pprint*
- "method-generic" word-prop pprint*
+ "method-class" word-prop pprint-word
+ "method-generic" word-prop pprint-word
method-stack-effect effect>string comment. ;
PRIVATE>
diff --git a/extra/lsys/strings/interpret/interpret.factor b/extra/lsys/strings/interpret/interpret.factor
index bcd87ca137..1d992cc1e2 100644
--- a/extra/lsys/strings/interpret/interpret.factor
+++ b/extra/lsys/strings/interpret/interpret.factor
@@ -1,6 +1,6 @@
USING: kernel sequences quotations assocs math math.parser
- combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.interpret
diff --git a/extra/lsys/strings/rewrite/rewrite.factor b/extra/lsys/strings/rewrite/rewrite.factor
index eb76dbd751..622a86c425 100644
--- a/extra/lsys/strings/rewrite/rewrite.factor
+++ b/extra/lsys/strings/rewrite/rewrite.factor
@@ -1,6 +1,6 @@
USING: kernel sbufs strings sequences assocs math
- combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings combinators.short-circuit ;
IN: lsys.strings.rewrite
diff --git a/extra/lsys/strings/strings.factor b/extra/lsys/strings/strings.factor
index f184ca5dfc..603c6cc630 100644
--- a/extra/lsys/strings/strings.factor
+++ b/extra/lsys/strings/strings.factor
@@ -1,5 +1,5 @@
-USING: kernel sequences math combinators.lib ;
+USING: kernel sequences math combinators.lib combinators.short-circuit ;
IN: lsys.strings
diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor
index d75915ae8e..ab679c8369 100644
--- a/extra/lsys/tortoise/graphics/graphics.factor
+++ b/extra/lsys/tortoise/graphics/graphics.factor
@@ -2,7 +2,7 @@
USING: kernel math vectors sequences opengl.gl math.vectors math.order
math.matrices vars opengl self pos ori turtle lsys.tortoise
- lsys.strings.interpret ;
+ lsys.strings.interpret combinators.short-circuit ;
! lsys.strings
diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor
index c3b9190c3c..8f9513ff2a 100644
--- a/extra/lsys/ui/ui.factor
+++ b/extra/lsys/ui/ui.factor
@@ -16,7 +16,8 @@ USING: kernel namespaces threads math math.order math.vectors
vars rewrite-closures
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics
- lsys.strings.rewrite lsys.strings.interpret ;
+ lsys.strings.rewrite lsys.strings.interpret
+ combinators.short-circuit ;
! lsys.strings
! lsys.strings.rewrite
@@ -100,17 +101,17 @@ DEFER: empty-model
{
-[ "Load" <label> dup reverse-video-theme ]
+[ "Load" <label> reverse-video-theme ]
[ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
[ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
-[ "Model" <label> dup reverse-video-theme ]
+[ "Model" <label> reverse-video-theme ]
[ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
[ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
-[ "Camera" <label> dup reverse-video-theme ]
+[ "Camera" <label> reverse-video-theme ]
[ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
[ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]
diff --git a/extra/match/match.factor b/extra/match/match.factor
index 8a174034ba..0ae285d20d 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser kernel words namespaces sequences classes.tuple
+USING: parser lexer kernel words namespaces sequences classes.tuple
combinators macros assocs math effects ;
IN: match
diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index 500e08f79d..b8256533bf 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting grouping sequences.lib ;
+ sequences splitting grouping sequences.lib
+ combinators.short-circuit ;
IN: math.text.english
<PRIVATE
diff --git a/extra/money/money.factor b/extra/money/money.factor
index 54c53e9bec..ba7a0ae04f 100644
--- a/extra/money/money.factor
+++ b/extra/money/money.factor
@@ -1,4 +1,4 @@
-USING: io kernel math math.functions math.parser parser
+USING: io kernel math math.functions math.parser parser lexer
namespaces sequences splitting grouping combinators
continuations sequences.lib ;
IN: money
diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor
index 3a4dc6fefb..1b5b6f2393 100644
--- a/extra/mortar/mortar.factor
+++ b/extra/mortar/mortar.factor
@@ -1,5 +1,5 @@
-USING: kernel io parser words namespaces quotations arrays assocs sequences
+USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
splitting grouping math shuffle ;
IN: mortar
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index ce79bdaf5f..cf671c5609 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces parser kernel sequences words quotations math ;
+USING: namespaces parser lexer kernel sequences words quotations math ;
IN: multiline
: next-line-text ( -- str )
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 88531a70bc..6596948f45 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,4 +1,4 @@
-USING: arrays combinators.lib kernel math math.functions
+USING: arrays kernel math math.functions
math.order math.vectors namespaces opengl opengl.gl sequences ui
ui.gadgets ui.gestures ui.render accessors ;
IN: opengl.demo-support
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index 8f2eee9459..fd547c8b5a 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,6 +1,6 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
-continuations ;
+continuations lexer ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index dced2e5c0c..e951ad8858 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -2,7 +2,7 @@
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces
-assocs parser sequences words quotations math.bitfields ;
+assocs parser lexer sequences words quotations math.bitfields ;
IN: openssl.libssl
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4725534178..3d48665c8c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.units words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
- peg.parsers unicode.categories multiline combinators combinators.lib
- splitting accessors effects sequences.deep peg.search inference
- io.streams.string io prettyprint parser ;
+ peg.parsers unicode.categories multiline combinators.lib
+ splitting accessors effects sequences.deep peg.search
+ combinators.short-circuit lexer io.streams.string inference io
+ prettyprint combinators parser ;
IN: peg.ebnf
: rule ( name word -- parser )
@@ -22,7 +23,7 @@ TUPLE: tokenizer any one many ;
: parser-tokenizer ( parser -- tokenizer )
[ 1quotation ] keep
- [ swap [ = ] curry semantic ] curry dup tokenizer boa ;
+ [ swap [ = ] curry semantic ] curry dup \ tokenizer boa ;
: rule-tokenizer ( name word -- tokenizer )
rule parser-tokenizer ;
diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor
index 5eb42daa31..b7df9908da 100644
--- a/extra/peg/javascript/parser/parser.factor
+++ b/extra/peg/javascript/parser/parser.factor
@@ -60,9 +60,9 @@ RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop
AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
| AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
| MulExpr
-MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
- | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
- | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
+MulExpr = MulExpr:x "*" Unary:y => [[ x y "*" ast-binop boa ]]
+ | MulExpr:x "/" Unary:y => [[ x y "/" ast-binop boa ]]
+ | MulExpr:x "%" Unary:y => [[ x y "%" ast-binop boa ]]
| Unary
Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
| "+" Postfix:p => [[ p ]]
@@ -89,7 +89,8 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]]
| String => [[ ast-string boa ]]
| RegExp => [[ ast-regexp boa ]]
| "function" FuncRest:fr => [[ fr ]]
- | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "new" PrimExpr:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "new" PrimExpr:n => [[ n f ast-new boa ]]
| "[" Args:es "]" => [[ es ast-array boa ]]
| Json
JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor
index a4e4ad33fe..45eb894e67 100644
--- a/extra/persistent-vectors/persistent-vectors-tests.factor
+++ b/extra/persistent-vectors/persistent-vectors-tests.factor
@@ -48,6 +48,10 @@ random namespaces vectors math math.order ;
[ ] [ PV{ } "1" set ] unit-test
[ ] [ V{ } clone "2" set ] unit-test
+: push/pop-test ( vec -- vec' ) 3 swap ppush 3 swap ppush ppop ;
+
+[ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test
+
[ t ] [
100 [
drop
diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor
index f9f4b68933..691ebfcf4d 100644
--- a/extra/persistent-vectors/persistent-vectors.factor
+++ b/extra/persistent-vectors/persistent-vectors.factor
@@ -1,7 +1,7 @@
! Based on Clojure's PersistentVector by Rich Hickey.
USING: math accessors kernel sequences.private sequences arrays
-combinators parser prettyprint.backend ;
+combinators combinators.short-circuit parser prettyprint.backend ;
IN: persistent-vectors
ERROR: empty-error pvec ;
@@ -123,30 +123,39 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' )
] if
] if ;
+: ppop-tail ( pvec -- pvec' )
+ [ clone [ ppop ] change-children ] change-tail ;
+
: (ppop-contraction) ( node -- node' tail' )
clone [ unclip-last swap ] change-children swap ;
: ppop-contraction ( node -- node' tail' )
- [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
+ dup children>> length 1 =
+ [ children>> peek f swap ]
+ [ (ppop-contraction) ]
+ if ;
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
- dup children>> peek (ppop-new-tail) over children>> empty?
- [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
+ dup children>> peek (ppop-new-tail) over
+ [ [ swap node-set-last ] dip ]
+ [ 2drop ppop-contraction ]
+ if
] [
ppop-contraction
] if ;
-: ppop-tail ( pvec -- pvec' )
- [ clone [ ppop ] change-children ] change-tail ;
+: trivial? ( node -- ? )
+ { [ level>> 1 > ] [ children>> length 1 = ] } 1&& ;
: ppop-new-tail ( pvec -- pvec' )
- dup root>> (ppop-new-tail)
- [
- dup [ level>> 1 > ] [ children>> length 1 = ] bi and
- [ children>> first ] when
- ] dip
- [ >>root ] [ >>tail ] bi* ;
+ dup root>> (ppop-new-tail) [
+ {
+ { [ dup not ] [ drop T{ node f { } 1 } ] }
+ { [ dup trivial? ] [ children>> first ] }
+ [ ]
+ } cond
+ ] dip [ >>root ] [ >>tail ] bi* ;
PRIVATE>
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index ef8ef8c0f7..b99e34d36f 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces sequences
- sorting ;
+ sorting combinators.short-circuit ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor
index ffff10d4fe..cf58e88ffe 100644
--- a/extra/project-euler/017/017.factor
+++ b/extra/project-euler/017/017.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.ranges math.text.english sequences sequences.lib strings
- ascii ;
+ ascii combinators.short-circuit ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor
index e6eadba264..f09b0c0b42 100644
--- a/extra/project-euler/021/021.factor
+++ b/extra/project-euler/021/021.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.ranges namespaces
- project-euler.common sequences sequences.lib ;
+ project-euler.common sequences sequences.lib
+ combinators.short-circuit ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 68b42ca442..8a54c595a9 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -31,11 +31,11 @@ IN: project-euler.032
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
- [ string>number ] 3apply [ * ] dip = ;
+ [ string>number ] tri@ [ * ] dip = ;
: 2and3 ( n -- ? )
number>string 2 cut-slice 3 cut-slice
- [ string>number ] 3apply [ * ] dip = ;
+ [ string>number ] tri@ [ * ] dip = ;
: valid? ( n -- ? )
dup 1and4 swap 2and3 or ;
@@ -65,7 +65,7 @@ PRIVATE>
! multiplicand/multiplier/product
: mmp ( pair -- n )
- first2 2dup * [ number>string ] 3apply 3append string>number ;
+ first2 2dup * [ number>string ] tri@ 3append string>number ;
PRIVATE>
diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor
index fbf6376eb3..4a4f906467 100644
--- a/extra/project-euler/036/036.factor
+++ b/extra/project-euler/036/036.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.parser math.ranges project-euler.common
- sequences ;
+ sequences combinators.short-circuit ;
IN: project-euler.036
! http://projecteuler.net/index.php?section=problems&id=36
diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
old mode 100644
new mode 100755
index 9075b19324..7a9f51f1d3
--- a/extra/project-euler/039/039.factor
+++ b/extra/project-euler/039/039.factor
@@ -44,7 +44,7 @@ SYMBOL: p-count
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] [ a-transform ] [ d-transform ] tri
- [ (count-perimeters) ] 3apply
+ [ (count-perimeters) ] tri@
] [
drop
] if ;
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 0c51146656..e095d94ead 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -1,7 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sequences.lib sorting sets ;
+ math.ranges project-euler.common sequences sequences.lib sorting
+ sets combinators.short-circuit ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index 6c4b605bd9..194530ea78 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -1,6 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel math project-euler.common sequences sorting ;
+USING: combinators.lib kernel math project-euler.common sequences
+sorting combinators.short-circuit ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
old mode 100644
new mode 100755
index 453ebfa129..8e5b849de5
--- a/extra/project-euler/075/075.factor
+++ b/extra/project-euler/075/075.factor
@@ -57,7 +57,7 @@ SYMBOL: p-count
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] [ a-transform ] [ d-transform ] tri
- [ (count-perimeters) ] 3apply
+ [ (count-perimeters) ] tri@
] [
drop
] if ;
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 9325e74d93..3101c900e3 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -17,7 +17,7 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
project-euler.052 project-euler.053 project-euler.056 project-euler.059
project-euler.067 project-euler.075 project-euler.079 project-euler.092
project-euler.097 project-euler.134 project-euler.169 project-euler.173
- project-euler.175 ;
+ project-euler.175 combinators.short-circuit ;
IN: project-euler
<PRIVATE
diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor
index 5810a03f80..d636cc0152 100644
--- a/extra/qualified/qualified.factor
+++ b/extra/qualified/qualified.factor
@@ -1,5 +1,7 @@
-USING: kernel sequences assocs hashtables parser vocabs words namespaces
-vocabs.loader debugger sets ;
+! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs hashtables parser lexer
+vocabs words namespaces vocabs.loader debugger sets ;
IN: qualified
: define-qualified ( vocab-name prefix-name -- )
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 99e6b887c8..c329977875 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -1,7 +1,8 @@
USING: arrays combinators kernel lists math math.parser
-namespaces parser parser-combinators parser-combinators.simple
+namespaces parser lexer parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
-assocs prettyprint.backend memoize unicode.case unicode.categories ;
+assocs prettyprint.backend memoize unicode.case unicode.categories
+combinators.short-circuit ;
USE: io
IN: regexp
@@ -20,9 +21,6 @@ SYMBOL: ignore-case?
[ [ between? ] ]
if 2curry ;
-: or-predicates ( quots -- quot )
- [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-
: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
@@ -179,7 +177,7 @@ C: <group-result> group-result
: 'positive-character-class' ( -- parser )
"]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
'character-class-term' <+> <|>
- [ or-predicates ] <@ ;
+ [ [ 1|| ] curry ] <@ ;
: 'negative-character-class' ( -- parser )
"^" token 'positive-character-class' &>
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 3537d2e719..fc8ba9821c 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -20,7 +20,6 @@ IN: reports.noise
{ 2swap 3 }
{ 2with 2 }
{ 2with* 3 }
- { 3apply 1/2 }
{ 3curry 2 }
{ 3drop 1 }
{ 3dup 2 }
diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index 7d50d384e2..89ad6fe2d0 100755
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators combinators.cleave combinators.lib
continuations db db.tuples db.types db.sqlite kernel math
-math.parser namespaces parser sets sequences sequences.deep
+math.parser namespaces parser lexer sets sequences sequences.deep
sequences.lib strings words destructors ;
IN: semantic-db
@@ -36,10 +36,10 @@ TUPLE: arc id subject object relation ;
: delete-arc ( arc -- ) delete-tuples ;
: create-arc ( subject object relation -- )
- [ id>> ] 3apply <arc> insert-tuple ;
+ [ id>> ] tri@ <arc> insert-tuple ;
: nodes>arc ( subject object relation -- arc )
- [ [ id>> ] [ f ] if* ] 3apply <arc> ;
+ [ [ id>> ] [ f ] if* ] tri@ <arc> ;
: select-arcs ( subject object relation -- arcs )
nodes>arc select-tuples ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 324b8d166d..feb3793098 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -238,9 +238,6 @@ PRIVATE>
: remove-nth ( seq n -- seq' )
cut-slice rest-slice append ;
-: short ( seq n -- seq n' )
- over length min ; inline
-
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline
diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor
index 8ba5b66d5a..45c6f1fb4d 100644
--- a/extra/shell/shell.factor
+++ b/extra/shell/shell.factor
@@ -2,7 +2,8 @@
USING: kernel parser words continuations namespaces debugger
sequences combinators splitting prettyprint
system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
- accessors multi-methods newfx shell.parser ;
+ accessors multi-methods newfx shell.parser
+ combinators.short-circuit ;
IN: shell
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
index 4c83c64641..b5e8c16b02 100755
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -1,4 +1,4 @@
-USING: kernel parser strings math namespaces sequences words io
+USING: kernel parser lexer strings math namespaces sequences words io
arrays quotations debugger kernel.private sequences.private ;
IN: state-machine
diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor
index 20cf16e640..6cf8eac6fb 100755
--- a/extra/symbols/symbols.factor
+++ b/extra/symbols/symbols.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words kernel classes.singleton ;
+USING: parser lexer sequences words kernel classes.singleton
+classes.parser ;
IN: symbols
: SYMBOLS:
diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor
index 32b3c925f3..8d4c91177a 100644
--- a/extra/syndication/syndication.factor
+++ b/extra/syndication/syndication.factor
@@ -53,7 +53,7 @@ TUPLE: entry title url description date ;
swap {
[ "title" tag-named children>string >>title ]
[ { "link" "guid" } any-tag-named children>string >url >>url ]
- [ "description" tag-named children>string >>description ]
+ [ { "description" "encoded" } any-tag-named children>string >>description ]
[
{ "date" "pubDate" } any-tag-named
children>string try-parsing-timestamp >>date
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 8ff22fb1ad..ed22902af2 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -49,12 +49,51 @@ namespaces continuations layouts accessors ;
cell 8 = 50 30 ? 100000 * small-enough?
] unit-test
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process
+ ] curry unit-test
+] each
+
+USING: http.client furnace.actions http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+: add-quit-action
+ <action>
+ [ stop-server "Goodbye" "text/html" <content> ] >>display
+ "quit" add-responder ;
+
+: test-httpd ( -- )
+ #! Return as soon as server is running.
+ <http-server>
+ 1237 >>insecure
+ f >>secure
+ start-server* ;
+
[ ] [
- "tools.deploy.test.1" shake-and-bake
- vm "-i=" "test.image" temp-file append 2array try-process
+ [
+ <dispatcher>
+ add-quit-action
+ "resource:extra/http/test" <static> >>default
+ main-responder set
+
+ test-httpd
+ ] with-scope
] unit-test
[ ] [
- "tools.deploy.test.2" shake-and-bake
- vm "-i=" "test.image" temp-file append 2array try-process
+ "tools.deploy.test.5" shake-and-bake
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process
] unit-test
+
+[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index db0f478709..5a20dd8911 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: qualified io.streams.c init fry namespaces assocs kernel
-parser tools.deploy.config vocabs sequences words words.private
-memory kernel.private continuations io prettyprint
-vocabs.loader debugger system strings sets ;
+parser lexer strings.parser tools.deploy.config vocabs sequences
+words words.private memory kernel.private continuations io
+prettyprint vocabs.loader debugger system strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@@ -66,28 +66,72 @@ IN: tools.deploy.shaker
: strip-word-defs ( words -- )
"Stripping symbolic word definitions" show
+ [ "no-def-strip" word-prop not ] filter
[ [ ] swap set-word-def ] each ;
-: strip-word-props ( retain-props words -- )
+: strip-word-props ( stripped-props words -- )
"Stripping word properties" show
[
[
word-props swap
- '[ , nip member? ] assoc-filter
+ '[ , nip member? not ] assoc-filter
f assoc-like
] keep set-word-props
] with each ;
-: retained-props ( -- seq )
+: stripped-word-props ( -- seq )
[
- "class" ,
- "metaclass" ,
- "layout" ,
- deploy-ui? get [
- "gestures" ,
- "commands" ,
- { "+nullary+" "+listener+" "+description+" }
- [ "ui.commands" lookup , ] each
+ strip-dictionary? [
+ {
+ "coercer"
+ "compiled-effect"
+ "compiled-uses"
+ "constraints"
+ "declared-effect"
+ "default-output-classes"
+ "identities"
+ "if-intrinsics"
+ "infer"
+ "inferred-effect"
+ "interval"
+ "intrinsics"
+ "loc"
+ "members"
+ "methods"
+ "combination"
+ "cannot-infer"
+ "default-method"
+ "optimizer-hooks"
+ "output-classes"
+ "participants"
+ "predicate"
+ "predicate-definition"
+ "predicating"
+ "slots"
+ "slot-names"
+ "specializer"
+ "step-into"
+ "step-into?"
+ "superclass"
+ "reading"
+ "writing"
+ "type"
+ "engines"
+ } %
+ ] when
+
+ strip-prettyprint? [
+ {
+ "delimiter"
+ "flushable"
+ "foldable"
+ "inline"
+ "lambda"
+ "macro"
+ "memo-quot"
+ "parsing"
+ "word-style"
+ } %
] when
] { } make ;
@@ -133,11 +177,11 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
- [
- io.backend:io-backend ,
- "default-buffer-size" "io.ports" lookup ,
- ] { } make
- { "alarms" "io" "tools" } strip-vocab-globals %
+ { } {
+ "alarms"
+ "tools"
+ "io.launcher"
+ } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
@@ -242,7 +286,7 @@ SYMBOL: deploy-vocab
strip-recompile-hook
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
- retained-props >r
+ stripped-word-props >r
stripped-globals strip-globals
r> strip-words ;
diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor
index 69287db4e2..5919fa15db 100755
--- a/extra/tools/deploy/test/3/3.factor
+++ b/extra/tools/deploy/test/3/3.factor
@@ -1,8 +1,7 @@
IN: tools.deploy.test.3
-USING: io.encodings.ascii io.files kernel ;
+USING: io.encodings.ascii io.encodings.string system kernel ;
: deploy-test-3 ( -- )
- "resource:extra/tools/deploy/test/3/3.factor"
- ascii file-contents drop ;
+ "xyzthg" ascii encode drop ;
MAIN: deploy-test-3
diff --git a/extra/tools/deploy/test/4/4.factor b/extra/tools/deploy/test/4/4.factor
new file mode 100644
index 0000000000..a9ee71131c
--- /dev/null
+++ b/extra/tools/deploy/test/4/4.factor
@@ -0,0 +1,7 @@
+IN: tools.deploy.test.4
+USING: io.encodings.8-bit io.encodings.string kernel ;
+
+: deploy-test-4 ( -- )
+ "xyzthg" \ latin7 encode drop ;
+
+MAIN: deploy-test-4
diff --git a/extra/tools/deploy/test/4/deploy.factor b/extra/tools/deploy/test/4/deploy.factor
new file mode 100644
index 0000000000..894d6aa62e
--- /dev/null
+++ b/extra/tools/deploy/test/4/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-math? f }
+ { deploy-reflection 1 }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-random? f }
+ { deploy-ui? f }
+ { deploy-name "tools.deploy.test.4" }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+}
diff --git a/extra/tools/deploy/test/5/5.factor b/extra/tools/deploy/test/5/5.factor
new file mode 100644
index 0000000000..debc020d49
--- /dev/null
+++ b/extra/tools/deploy/test/5/5.factor
@@ -0,0 +1,7 @@
+IN: tools.deploy.test.5
+USING: http.client kernel ;
+
+: deploy-test-5 ( -- )
+ "http://localhost:1237/foo.html" http-get 2drop ;
+
+MAIN: deploy-test-5
diff --git a/extra/tools/deploy/test/5/deploy.factor b/extra/tools/deploy/test/5/deploy.factor
new file mode 100644
index 0000000000..87536457b0
--- /dev/null
+++ b/extra/tools/deploy/test/5/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-reflection 2 }
+ { deploy-io 3 }
+ { deploy-c-types? f }
+ { deploy-random? t }
+ { deploy-ui? f }
+ { deploy-name "tools.deploy.test.5" }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+}
diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor
index cf439f6407..ce717f4211 100755
--- a/extra/tuple-syntax/tuple-syntax.factor
+++ b/extra/tuple-syntax/tuple-syntax.factor
@@ -1,4 +1,4 @@
-USING: kernel sequences slots parser words classes
+USING: kernel sequences slots parser lexer words classes
slots.private mirrors ;
IN: tuple-syntax
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 0db38e5eca..b0653ffa39 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -110,7 +110,6 @@ M: cocoa-ui-backend ui
"UI" assert.app [
[
init-clipboard
- stop-after-last-window? off
cocoa-init-hook get [ call ] when*
start-ui
finish-launching
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index e452e6c455..c36d2050c9 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/extra/ui/gadgets/buttons/buttons.factor
@@ -41,7 +41,7 @@ button H{
: <button> ( gadget quot -- button )
button new
- [ set-button-quot ] keep
+ swap >>quot
[ set-gadget-delegate ] keep ;
TUPLE: button-paint plain rollover pressed selected ;
@@ -53,10 +53,10 @@ C: <button-paint> button-paint
: button-paint ( button paint -- button paint )
over find-button {
- { [ dup button-pressed? ] [ drop button-paint-pressed ] }
- { [ dup button-selected? ] [ drop button-paint-selected ] }
- { [ dup button-rollover? ] [ drop button-paint-rollover ] }
- [ drop button-paint-plain ]
+ { [ dup pressed?>> ] [ drop pressed>> ] }
+ { [ dup selected?>> ] [ drop selected>> ] }
+ { [ dup button-rollover? ] [ drop rollover>> ] }
+ [ drop plain>> ]
} cond ;
M: button-paint draw-interior
@@ -65,25 +65,26 @@ M: button-paint draw-interior
M: button-paint draw-boundary
button-paint draw-boundary ;
-: roll-button-theme ( button -- )
- f black <solid> dup f <button-paint>
- swap set-gadget-boundary ;
+: roll-button-theme ( button -- button )
+ f black <solid> dup f <button-paint> >>boundary ; inline
: <roll-button> ( label quot -- button )
- >r >label r>
- <button> dup roll-button-theme ;
+ >r >label r> <button> roll-button-theme ;
-: bevel-button-theme ( gadget -- )
+: <bevel-button-paint> ( -- paint )
plain-gradient
rollover-gradient
pressed-gradient
selected-gradient
- <button-paint> over set-gadget-interior
- faint-boundary ;
+ <button-paint> ;
+
+: bevel-button-theme ( gadget -- gadget )
+ <bevel-button-paint> >>interior
+ faint-boundary ; inline
: <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
- <button> dup bevel-button-theme ;
+ <button> bevel-button-theme ;
TUPLE: repeat-button ;
diff --git a/extra/ui/gadgets/canvas/canvas.factor b/extra/ui/gadgets/canvas/canvas.factor
index 15df44fda4..0a9f07ed6e 100644
--- a/extra/ui/gadgets/canvas/canvas.factor
+++ b/extra/ui/gadgets/canvas/canvas.factor
@@ -9,7 +9,7 @@ TUPLE: canvas dlist ;
: <canvas> ( -- canvas )
canvas construct-gadget
- dup black solid-interior ;
+ black solid-interior ;
: delete-canvas-dlist ( canvas -- )
dup find-gl-context
diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor
index 63ab2f1d6f..3013dcd0bd 100755
--- a/extra/ui/gadgets/labelled/labelled.factor
+++ b/extra/ui/gadgets/labelled/labelled.factor
@@ -13,7 +13,7 @@ TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new
[
- <label> dup reverse-video-theme f track,
+ <label> reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
] { 0 1 } build-track ;
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index 167aa26084..f800b12120 100755
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/extra/ui/gadgets/labels/labels.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math namespaces
+USING: accessors arrays hashtables io kernel math namespaces
opengl sequences strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
@@ -10,7 +10,7 @@ IN: ui.gadgets.labels
TUPLE: label text font color ;
: label-string ( label -- string )
- label-text dup string? [ "\n" join ] unless ; inline
+ text>> dup string? [ "\n" join ] unless ; inline
: set-label-string ( string label -- )
CHAR: \n pick memq? [
@@ -19,21 +19,21 @@ TUPLE: label text font color ;
set-label-text
] if ; inline
-: label-theme ( gadget -- )
- black over set-label-color
- sans-serif-font swap set-label-font ;
+: label-theme ( gadget -- gadget )
+ sans-serif-font >>font
+ black >>color ; inline
: <label> ( string -- label )
label construct-gadget
[ set-label-string ] keep
- dup label-theme ;
+ label-theme ;
M: label pref-dim*
- dup label-font open-font swap label-text text-dim ;
+ [ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- dup label-color gl-color
- dup label-font swap label-text origin get draw-text ;
+ [ color>> gl-color ]
+ [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ;
@@ -45,12 +45,12 @@ M: label-control model-changed
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;
-: text-theme ( gadget -- )
- black over set-label-color
- monospace-font swap set-label-font ;
+: text-theme ( gadget -- gadget )
+ black >>color
+ monospace-font >>font ;
-: reverse-video-theme ( label -- )
- white over set-label-color
+: reverse-video-theme ( label -- label )
+ white >>color
black solid-interior ;
GENERIC: >label ( obj -- gadget )
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index fd5234ab03..43c0539e91 100755
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.commands ui.gestures ui.render ui.gadgets
+USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
@@ -27,17 +27,18 @@ TUPLE: list index presenter color hook ;
swap set-list-index ;
: list-presentation-hook ( list -- quot )
- list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
+ hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
- [ set-presentation-hook ] keep
- [ text-theme ] keep ;
+ swap >>hook
+ text-theme ; inline
: <list-items> ( list -- seq )
- dup list-presentation-hook
- over list-presenter
- rot control-value [
+ [ list-presentation-hook ]
+ [ presenter>> ]
+ [ control-value ]
+ tri [
>r 2dup r> swap <list-presentation>
] map 2nip ;
diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor
index 34051eaac0..153b4aeb6e 100644
--- a/extra/ui/gadgets/menus/menus.factor
+++ b/extra/ui/gadgets/menus/menus.factor
@@ -42,11 +42,11 @@ M: menu-glass layout* gadget-child prefer ;
[ hand-clicked get find-world hide-glass ]
3append <roll-button> ;
-: menu-theme ( gadget -- )
- dup light-gray solid-interior
+: menu-theme ( gadget -- gadget )
+ light-gray solid-interior
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
[
[ >r 2dup r> <menu-item> gadget, ] each 2drop
- ] make-filled-pile 5 <border> dup menu-theme ;
+ ] make-filled-pile 5 <border> menu-theme ;
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 880fb4450e..86d95e8ad0 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -182,7 +182,7 @@ M: pane-stream make-span-stream
foreground [ over set-label-color ] apply-style ;
: apply-background-style ( style gadget -- style gadget )
- background [ dupd solid-interior ] apply-style ;
+ background [ solid-interior ] apply-style ;
: specified-font ( style -- font )
[ font swap at "monospace" or ] keep
@@ -207,15 +207,15 @@ M: pane-stream make-span-stream
: apply-wrap-style ( style pane -- style pane )
wrap-margin [
- 2dup <paragraph> swap set-pane-prototype
- <paragraph> over set-pane-current
+ 2dup <paragraph> >>prototype drop
+ <paragraph> >>current
] apply-style ;
: apply-border-color-style ( style gadget -- style gadget )
- border-color [ dupd solid-boundary ] apply-style ;
+ border-color [ solid-boundary ] apply-style ;
: apply-page-color-style ( style gadget -- style gadget )
- page-color [ dupd solid-interior ] apply-style ;
+ page-color [ solid-interior ] apply-style ;
: apply-path-style ( style gadget -- style gadget )
presented-path [ <editable-slot> ] apply-style ;
@@ -224,9 +224,7 @@ M: pane-stream make-span-stream
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
- presented-printer [
- [ make-pane ] curry over set-editable-slot-printer
- ] apply-style ;
+ presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
@@ -294,11 +292,8 @@ M: pack dispose drop ;
M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
- over empty? [
- 2drop
- ] [
- >r <label> dup text-theme r> add-gadget
- ] if ;
+ over empty?
+ [ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
M: pack stream-write gadget-write ;
@@ -372,11 +367,11 @@ M: f sloppy-pick-up*
: extend-selection ( pane -- )
hand-moved? [
- dup pane-selecting? [
+ dup selecting?>> [
dup move-caret
] [
dup hand-clicked get child? [
- t over set-pane-selecting?
+ t >>selecting?
dup hand-clicked set-global
dup move-caret
dup caret>mark
@@ -386,10 +381,9 @@ M: f sloppy-pick-up*
] when drop ;
: end-selection ( pane -- )
- f over set-pane-selecting?
+ f >>selecting?
hand-moved? [
- dup com-copy-selection
- request-focus
+ [ com-copy-selection ] [ request-focus ] bi
] [
relayout-1
] if ;
diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor
index e513853d27..e58fbc5925 100755
--- a/extra/ui/gadgets/scrollers/scrollers.factor
+++ b/extra/ui/gadgets/scrollers/scrollers.factor
@@ -46,7 +46,7 @@ scroller H{
y-model <y-slider> g-> set-scroller-y @right frame,
viewport,
] with-gadget
- ] keep t over set-gadget-root? dup faint-boundary ;
+ ] keep t >>root? faint-boundary ;
: scroll ( value scroller -- )
[
diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor
index c781a9167d..eb22a5a823 100755
--- a/extra/ui/gadgets/sliders/sliders.factor
+++ b/extra/ui/gadgets/sliders/sliders.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
+USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models math.vectors math.functions quotations colors ;
@@ -65,14 +65,15 @@ thumb H{
{ T{ drag } [ do-drag ] }
} set-gestures
-: thumb-theme ( thumb -- )
- plain-gradient over set-gadget-interior faint-boundary ;
+: thumb-theme ( thumb -- thumb )
+ plain-gradient >>interior
+ faint-boundary ; inline
: <thumb> ( vector -- thumb )
thumb construct-gadget
- t over set-gadget-root?
- dup thumb-theme
- [ set-gadget-orientation ] keep ;
+ swap >>orientation
+ t >>root?
+ thumb-theme ;
: slide-by ( amount slider -- )
gadget-model move-by ;
diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor
index b528d6739c..417826a680 100755
--- a/extra/ui/gadgets/status-bar/status-bar.factor
+++ b/extra/ui/gadgets/status-bar/status-bar.factor
@@ -1,14 +1,14 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: models sequences ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
-calendar ;
+USING: accessors models sequences ui.gadgets.labels
+ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
+ui kernel calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <filter> <label-control>
- dup reverse-video-theme
- t over set-gadget-root? ;
+ reverse-video-theme
+ t >>root? ;
: open-status-window ( gadget title -- )
>r [
diff --git a/extra/ui/gadgets/theme/theme.factor b/extra/ui/gadgets/theme/theme.factor
index f0884f9486..68bd3b201a 100644
--- a/extra/ui/gadgets/theme/theme.factor
+++ b/extra/ui/gadgets/theme/theme.factor
@@ -2,17 +2,17 @@
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors ;
+colors accessors ;
IN: ui.gadgets.theme
-: solid-interior ( gadget color -- )
- <solid> swap set-gadget-interior ;
+: solid-interior ( gadget color -- gadget )
+ <solid> >>interior ; inline
-: solid-boundary ( gadget color -- )
- <solid> swap set-gadget-boundary ;
+: solid-boundary ( gadget color -- gadget )
+ <solid> >>boundary ; inline
-: faint-boundary ( gadget -- )
- gray solid-boundary ;
+: faint-boundary ( gadget -- gadget )
+ gray solid-boundary ; inline
: selection-color ( -- color ) light-purple ;
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index 2895dd07cc..4d2f31cda5 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs continuations kernel math models
namespaces opengl sequences io combinators math.vectors
-ui.gadgets ui.gestures ui.render ui.backend inspector ;
+ui.gadgets ui.gestures ui.render ui.backend inspector
+debugger ;
IN: ui.gadgets.worlds
TUPLE: world < identity-tuple
@@ -78,7 +79,8 @@ TUPLE: world-error world ;
SYMBOL: ui-error-hook
-: ui-error ( error -- ) ui-error-hook get call ;
+: ui-error ( error -- )
+ ui-error-hook get [ call ] [ print-error ] if* ;
[ rethrow ] ui-error-hook set-global
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
index f8d5e33df9..37f43faa8b 100755
--- a/extra/ui/tools/interactor/interactor-tests.factor
+++ b/extra/ui/tools/interactor/interactor-tests.factor
@@ -1,7 +1,7 @@
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser accessors ;
+tools.test kernel calendar parser accessors calendar io ;
\ <interactor> must-infer
@@ -41,3 +41,47 @@ tools.test kernel calendar parser accessors ;
[ ] [ 1000 sleep ] unit-test
[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+: text "Hello world.\nThis is a test." ;
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get contents "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get stream-read1 "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 400169908b..fcd3f9ab22 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
-models namespaces parser prettyprint quotations sequences
+models namespaces parser lexer prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors sets ;
+concurrency.mailboxes ui.tools.workspace accessors sets
+destructors ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
@@ -110,9 +111,11 @@ M: interactor model-changed
} cleave
] [ drop f ] if ;
+: interactor-read ( interactor -- lines )
+ [ interactor-yield ] [ interactor-finish ] bi ;
+
M: interactor stream-readln
- [ interactor-yield ] [ interactor-finish ] bi
- dup [ first ] when ;
+ interactor-read dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
@@ -124,19 +127,29 @@ M: interactor stream-read
swap dup zero? [
2drop ""
] [
- >r stream-readln dup length r> min head
+ >r interactor-read dup [ "\n" join ] when r> short head
] if ;
M: interactor stream-read-partial
stream-read ;
+M: interactor stream-read1
+ dup interactor-read {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup empty? ] [ drop stream-read1 ] }
+ { [ dup first empty? ] [ 2drop CHAR: \n ] }
+ [ nip first first ]
+ } cond ;
+
+M: interactor dispose drop ;
+
: go-to-error ( interactor error -- )
[ line>> 1- ] [ column>> ] bi 2array
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error error>> ] when
+ dup lexer-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
@@ -144,7 +157,7 @@ M: interactor stream-read-partial
drop parse-lines-interactive
] [
2nip
- dup parse-error? [
+ dup lexer-error? [
dup error>> unexpected-eof? [ drop f ] when
] when
] recover ;
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index b70d79b872..fe19685b53 100755
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,8 +1,7 @@
-USING: unicode.categories kernel math combinators splitting
+USING: combinators.short-circuit unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
math.ranges unicode.normalize values io.encodings.ascii
-unicode.syntax unicode.data compiler.units alien.syntax sets
-combinators.lib ;
+unicode.syntax unicode.data compiler.units alien.syntax sets ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor
index 5de90d238d..d523a15ada 100755
--- a/extra/unicode/collation/collation-tests.factor
+++ b/extra/unicode/collation/collation-tests.factor
@@ -1,6 +1,6 @@
USING: io io.files splitting grouping unicode.collation
sequences kernel io.encodings.utf8 math.parser math.order
-tools.test assocs io.streams.null words combinators.lib ;
+tools.test assocs io.streams.null words ;
IN: unicode.collation.tests
: parse-test ( -- strings )
@@ -17,7 +17,7 @@ IN: unicode.collation.tests
: test-equality
{ primary= secondary= tertiary= quaternary= }
- [ execute ] 2with each ;
+ [ execute ] with with each ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor
index 216f80c79d..3e239430d4 100755
--- a/extra/unicode/collation/collation.factor
+++ b/extra/unicode/collation/collation.factor
@@ -1,7 +1,7 @@
-USING: sequences io.files io.encodings.ascii kernel values
-splitting accessors math.parser ascii io assocs strings math
-namespaces sorting combinators math.order arrays
-unicode.normalize unicode.data combinators.lib locals
+USING: combinators.short-circuit sequences io.files
+io.encodings.ascii kernel values splitting accessors math.parser
+ascii io assocs strings math namespaces sorting combinators
+math.order arrays unicode.normalize unicode.data locals
unicode.syntax macros sequences.deep words unicode.breaks
quotations ;
IN: unicode.collation
@@ -86,7 +86,7 @@ ducet insert-helpers
: add ( char -- )
dup blocked? [ 1string , ] [
dup possible-bases dup length
- [ ?combine ] 2with contains?
+ [ ?combine ] with with contains?
[ drop ] [ 1string , ] if
] if ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 5fb769e499..f74e2e0473 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,8 +1,8 @@
-USING: assocs math kernel sequences io.files hashtables
-quotations splitting grouping arrays math.parser hash2 math.order
-byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets
-combinators.lib combinators locals math.ranges sorting ;
+USING: combinators.short-circuit assocs math kernel sequences
+io.files hashtables quotations splitting grouping arrays
+math.parser hash2 math.order byte-arrays words namespaces words
+compiler.units parser io.encodings.ascii values interval-maps
+ascii sets combinators locals math.ranges sorting ;
IN: unicode.data
VALUE: simple-lower
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index 3b64cf577f..124840a7fb 100755
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sorting.insertion combinators.lib ;
+locals sorting.insertion ;
IN: unicode.normalize
! Conjoining Jamo behavior
diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor
index b5ba25db4e..2410779804 100755
--- a/extra/unicode/syntax/syntax.factor
+++ b/extra/unicode/syntax/syntax.factor
@@ -1,4 +1,4 @@
-USING: unicode.data kernel math sequences parser bit-arrays
+USING: unicode.data kernel math sequences parser lexer bit-arrays
namespaces sequences.private arrays quotations assocs
classes.predicate math.order ;
IN: unicode.syntax
diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor
index 38511de8e8..4c45164815 100644
--- a/extra/urls/urls.factor
+++ b/extra/urls/urls.factor
@@ -1,22 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel unicode.categories combinators sequences splitting
-fry namespaces assocs arrays strings io.sockets
-io.sockets.secure io.encodings.string io.encodings.utf8
-math math.parser accessors mirrors parser
-prettyprint.backend hashtables present ;
+USING: kernel unicode.categories combinators
+combinators.short-circuit sequences splitting fry namespaces
+assocs arrays strings io.sockets io.sockets.secure
+io.encodings.string io.encodings.utf8 math math.parser accessors
+mirrors parser strings.parser lexer prettyprint.backend
+hashtables present ;
IN: urls
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
- { [ dup letter? ] [ t ] }
- { [ dup LETTER? ] [ t ] }
- { [ dup digit? ] [ t ] }
- { [ dup "/_-." member? ] [ t ] }
- [ f ]
- } cond nip ; foldable
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "/_-." member? ]
+ } 1|| ; foldable
<PRIVATE
diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor
index 5942215a69..e3e13be3a9 100644
--- a/extra/vars/vars.factor
+++ b/extra/vars/vars.factor
@@ -2,7 +2,7 @@
! Thanks to Mackenzie Straight for the idea
-USING: kernel parser words namespaces sequences quotations ;
+USING: kernel parser lexer words namespaces sequences quotations ;
IN: vars
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 80a4a040c4..e0ea65e8be 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -1,5 +1,5 @@
-USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
-parser splitting grouping sequences.lib sequences namespaces
+USING: alien alien.c-types effects kernel windows.ole32
+parser lexer splitting grouping sequences.lib sequences namespaces
assocs quotations shuffle accessors words macros alien.syntax
fry arrays ;
IN: windows.com.syntax
diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor
index 6d6aa078e8..266439ad79 100755
--- a/extra/windows/com/wrapper/wrapper.factor
+++ b/extra/windows/com/wrapper/wrapper.factor
@@ -2,8 +2,8 @@ USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors fry
-math.parser ;
+math words compiler.units destructors fry
+math.parser combinators.lib ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls disposed ;
@@ -84,7 +84,7 @@ unless
swap append ;
: compile-alien-callback ( word return parameters abi quot -- alien )
- [ alien-callback ] 4 ncurry
+ '[ , , , , alien-callback ]
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index 0ac41a18ea..108e02cb46 100755
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -1182,7 +1182,8 @@ FUNCTION: BOOL IsProcessorFeaturePresent ( DWORD ProcessorFeature ) ;
! FUNCTION: LeaveCriticalSection
! FUNCTION: LoadLibraryA
! FUNCTION: LoadLibraryExA
-! FUNCTION: LoadLibraryExW
+FUNCTION: HMODULE LoadLibraryExW ( LPCTSTR lpFile, HANDLE hFile, DWORD flags ) ;
+ALIAS: LoadLibraryEx LoadLibraryExW
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
old mode 100644
new mode 100755
index a71a569f16..7daba37063
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows windows.types combinators.lib
+kernel sequences windows windows.types
math.order ;
IN: windows.ole32
@@ -132,5 +132,5 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
- [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;
+ [ StringFromGUID2 drop ] 2keep drop utf16n alien>string ;
diff --git a/extra/xml/generator/generator.factor b/extra/xml/generator/generator.factor
index 44bd1934f8..bf4bd618b7 100644
--- a/extra/xml/generator/generator.factor
+++ b/extra/xml/generator/generator.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel xml.data xml.utilities assocs splitting
-sequences parser quotations sequences.lib xml.utilities ;
+sequences parser lexer quotations sequences.lib xml.utilities ;
IN: xml.generator
: comment, ( string -- ) <comment> , ;
@@ -36,7 +36,7 @@ IN: xml.generator
[ \ contained*, parsed ] [
scan-word \ [ =
[ POSTPONE: [ \ tag*, parsed ]
- [ "Expected [ missing" <parse-error> throw ] if
+ [ "Expected [ missing" throw ] if
] if ;
DEFER: >>
diff --git a/extra/xml/utilities/utilities-tests.factor b/extra/xml/utilities/utilities-tests.factor
new file mode 100644
index 0000000000..c150c7133d
--- /dev/null
+++ b/extra/xml/utilities/utilities-tests.factor
@@ -0,0 +1,8 @@
+IN: xml.utilities.tests
+USING: xml xml.utilities tools.test ;
+
+[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo/>" string>xml children>string ] unit-test
diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor
index 87a0242412..e1875bd0c1 100755
--- a/extra/xml/utilities/utilities.factor
+++ b/extra/xml/utilities/utilities.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences words io assocs
-quotations strings parser arrays xml.data xml.writer debugger
-splitting vectors sequences.deep ;
+quotations strings parser lexer arrays xml.data xml.writer debugger
+splitting vectors sequences.deep combinators ;
IN: xml.utilities
! * System for words specialized on tag names
@@ -48,10 +48,11 @@ M: process-missing error.
standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
- tag-children
- dup [ string? ] all?
- [ "XML tag unexpectedly contains non-text children" throw ] unless
- concat ;
+ tag-children {
+ { [ dup empty? ] [ drop "" ] }
+ { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+ [ concat ]
+ } cond ;
: children-tags ( tag -- sequence )
tag-children [ tag? ] filter ;
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
index b3adf5cb60..4c95a45832 100644
--- a/extra/xmode/loader/syntax/syntax.factor
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -1,6 +1,6 @@
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
xml.utilities xml assocs kernel combinators sequences
-math.parser namespaces parser xmode.utilities regexp io.files ;
+math.parser namespaces parser lexer xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor
index 7d82842327..911397cc20 100755
--- a/extra/xmode/marker/marker.factor
+++ b/extra/xmode/marker/marker.factor
@@ -2,7 +2,8 @@ IN: xmode.marker
USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib
-strings regexp splitting parser-combinators ascii unicode.case ;
+strings regexp splitting parser-combinators ascii unicode.case
+combinators.short-circuit ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index 2e1d0a2872..d6f9c42799 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -1,5 +1,5 @@
USING: sequences assocs kernel quotations namespaces xml.data
-xml.utilities combinators macros parser words ;
+xml.utilities combinators macros parser lexer words ;
IN: xmode.utilities
: implies >r not r> or ; inline