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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-06-27 19:41:03 -05:00
parent 90624a8764 8e8c913d55
commit 6fa3b93868
175 changed files with 1721 additions and 1041 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/alien/syntax/syntax.factor
View File

@ -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

9
core/classes/classes.factor
View File

@ -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 )

3
core/classes/intersection/intersection.factor
View File

@ -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 ;

2
core/classes/mixin/mixin.factor
View File

@ -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 ;

15
core/classes/parser/parser.factor Normal file
View File

@ -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 ;

9
core/classes/predicate/predicate.factor
View File

@ -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 ;

14
core/classes/tuple/parser/parser-docs.factor Normal file
View File

@ -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 -- ) ... ;"
}
} ;

50
core/classes/tuple/parser/parser.factor Normal file
View File

@ -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 ;

13
core/classes/tuple/tuple-tests.factor
View File

@ -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

40
core/classes/tuple/tuple.factor
View File

@ -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 ;

3
core/classes/union/union.factor
View File

@ -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 ;

1
core/compiler/compiler.factor
View File

@ -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

8
core/continuations/continuations-docs.factor
View File

@ -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

20
core/cpu/x86/assembler/assembler.factor
View File

@ -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 ;

15
core/cpu/x86/assembler/syntax/syntax.factor Normal file
View File

@ -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

7
core/debugger/debugger.factor
View File

@ -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" ;

4
core/effects/effects.factor
View File

@ -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* ;

9
core/effects/parser/parser-docs.factor Normal file
View File

@ -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 ;

15
core/effects/parser/parser.factor Normal file
View File

@ -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 ;

33
core/generic/parser/parser.factor Normal file
View File

@ -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 ;

2
core/inference/backend/backend.factor
View File

@ -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 -- )

8
core/inference/transforms/transforms-tests.factor
View File

@ -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

26
core/inference/transforms/transforms.factor
View File

@ -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

26
core/inspector/inspector-tests.factor
View File

@ -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

11
core/inspector/inspector.factor
View File

@ -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

5
core/kernel/kernel-tests.factor
View File

@ -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

109
core/lexer/lexer-docs.factor Normal file
View File

@ -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 } ;

133
core/lexer/lexer.factor Normal file
View File

@ -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

4
core/listener/listener.factor
View File

@ -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

9
core/mirrors/mirrors.factor
View File

@ -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> ;

2
core/optimizer/math/partial/partial.factor
View File

@ -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

152
core/parser/parser-docs.factor
View File

@ -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 } }

20
core/parser/parser-tests.factor
View File

@ -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

326
core/parser/parser.factor
View File

@ -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 -- )

6
core/prettyprint/prettyprint-tests.factor
View File

@ -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"

2
core/sequences/sequences.factor
View File

@ -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> ;

26
core/source-files/source-files.factor
View File

@ -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

16
core/strings/parser/parser-docs.factor Normal file
View File

@ -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 ;

62
core/strings/parser/parser.factor Normal file
View File

@ -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 ;

17
core/syntax/syntax.factor
View File

@ -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

2
core/vocabs/loader/loader-tests.factor
View File

@ -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

2
extra/bitfields/bitfields.factor
View File

@ -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

2
extra/boids/boids.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces
USING: combinators.short-circuit kernel namespaces
math
math.constants
math.functions

10
extra/boids/ui/ui.factor
View File

@ -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>

2
extra/bootstrap/unicode/unicode.factor
View File

@ -1,4 +1,4 @@
USING: parser kernel namespaces ;
USING: strings.parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case

14
extra/bunny/deploy.factor
View File

@ -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 }
}

3
extra/cocoa/cocoa.factor
View File

@ -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 -- )

32
extra/combinators/lib/lib-tests.factor
View File

@ -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

43
extra/combinators/lib/lib.factor
View File

@ -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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

32
extra/combinators/short-circuit/short-circuit-tests.factor Normal file
View File

@ -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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

33
extra/combinators/short-circuit/short-circuit.factor Normal file
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

32
extra/combinators/short-circuit/smart/smart-tests.factor Normal file
View File

@ -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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

11
extra/combinators/short-circuit/smart/smart.factor Normal file
View File

@ -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 ;

4
extra/concurrency/distributed/distributed-tests.factor
View File

@ -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

17
extra/concurrency/distributed/distributed.factor
View File

@ -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) ;

2
extra/cpu/8080/emulator/emulator.factor
View File

@ -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

2
extra/dns/forwarding/forwarding.factor
View File

@ -1,5 +1,5 @@
USING: kernel
USING: combinators.short-circuit kernel
combinators
vectors
sequences

2
extra/dns/server/server.factor
View File

@ -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 ;

4
extra/editors/editors-docs.factor
View File

@ -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" } "." } ;

42
extra/editors/editors.factor
View File

@ -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 -- )
[

2
extra/ftp/server/server.factor
View File

@ -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

4
extra/furnace/auth/login/permits/permits.factor
View File

@ -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 ;

2
extra/furnace/boilerplate/boilerplate.factor
View File

@ -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 ;

2
extra/furnace/sessions/sessions.factor
View File

@ -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? ;

9
extra/gesture-logger/gesture-logger.factor
View File

@ -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

1
extra/graph-theory/authors.txt Normal file
View File

@ -0,0 +1 @@
William Schlieper

135
extra/graph-theory/graph-theory-docs.factor Normal file
View File

@ -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." } ;

92
extra/graph-theory/graph-theory.factor Normal file
View File

@ -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 ;

22
extra/graph-theory/reversals/reversals.factor Normal file
View File

@ -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? ;

35
extra/graph-theory/sparse/sparse.factor Normal file
View File

@ -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 ;

1
extra/graph-theory/summary.txt Normal file
View File

@ -0,0 +1 @@
Graph-theoretic algorithms

1
extra/graph-theory/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

2
extra/help/handbook/handbook.factor
View File

@ -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"

5
extra/help/markup/markup.factor
View File

@ -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 ;

2
extra/html/templates/chloe/syntax/syntax.factor
View File

@ -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

6
extra/html/templates/fhtml/fhtml.factor
View File

@ -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 )
[

41
extra/http/http-tests.factor
View File

@ -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 ;

5
extra/http/http.factor
View File

@ -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 )

2
extra/http/parsers/parsers.factor
View File

@ -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

2
extra/inverse/inverse.factor
View File

@ -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 ;

9
extra/io/encodings/8-bit/8-bit-docs.factor
View File

@ -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" } ;

52
extra/io/encodings/8-bit/8-bit.factor
View File

@ -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

16
extra/io/servers/connection/connection-tests.factor
View File

@ -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

29
extra/io/servers/connection/connection.factor
View File

@ -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 ;

8
extra/io/sockets/secure/secure-tests.factor Normal file → Executable file
View File

@ -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

8
extra/io/windows/files/files.factor
View File

@ -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 -- )

2
extra/io/windows/nt/backend/backend.factor
View File

@ -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

17
extra/io/windows/nt/files/files.factor
View File

@ -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? [

10
extra/io/windows/nt/launcher/launcher.factor
View File

@ -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

1
extra/io/windows/nt/nt.factor
View File

@ -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

4
extra/io/windows/nt/pipes/pipes.factor
View File

@ -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

3
extra/io/windows/sockets/sockets.factor
View File

@ -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 ;

5
extra/io/windows/windows.factor
View File

@ -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 ;

3
extra/lcs/lcs.factor
View File

@ -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

2
extra/lisp/lisp.factor
View File

@ -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

2
extra/lisp/parser/parser.factor
View File

@ -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

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

@ -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

8
extra/locals/locals.factor
View File

@ -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>

2
extra/lsys/strings/interpret/interpret.factor
View File

@ -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

2
extra/lsys/strings/rewrite/rewrite.factor
View File

@ -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

Some files were not shown because too many files have changed in this diff Show More