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

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

Eduardo Cavazos 2008-03-20 17:33:23 -06:00
parent 010856c870 a6e1d83740
commit 0d5bfa9fd2
82 changed files with 641 additions and 633 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/alien/alien.factor
View File

@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
TUPLE: alien-callback return parameters abi quot xt ;
TUPLE: alien-callback-error ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
\ alien-callback-error construct-empty throw ;
alien-callback-error ;
TUPLE: alien-indirect return parameters abi ;
TUPLE: alien-indirect-error ;
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
\ alien-indirect-error construct-empty throw ;
alien-indirect-error ;
TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke-error library symbol ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
2over \ alien-invoke-error construct-boa throw ;
2over alien-invoke-error ;

4
core/alien/c-types/c-types.factor
View File

@ -26,9 +26,7 @@ global [
c-types [ H{ } assoc-like ] change
] bind
TUPLE: no-c-type name ;
: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
ERROR: no-c-type name ;
: (c-type) ( name -- type/f )
c-types get-global at dup [

61
core/alien/structs/structs-docs.factor
View File

@ -1,6 +1,65 @@
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays ;
alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces ;
! Deprecated code
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
[ { $instance } swap add ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
over [
2dup $spec-reader-values
2dup $spec-reader-description
] when 2drop ;
GENERIC: slot-specs ( help-type -- specs )
M: word slot-specs "slots" word-prop ;
: $slot-reader ( reader -- )
first dup "reading" word-prop [ slot-specs ] keep
$spec-reader ;
: $spec-writer-values ( slot-spec class -- )
($spec-reader-values) reverse $values ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
{ $snippet } rot slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
over [
2dup $spec-writer-values
2dup $spec-writer-description
dup ?word-name 1array $side-effects
] when 2drop ;
: $slot-writer ( reader -- )
first dup "writing" word-prop [ slot-specs ] keep
$spec-writer ;
M: string slot-specs c-type struct-type-fields ;

2
core/alien/structs/structs.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
alien.c-types cpu.architecture ;
slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )

2
core/bootstrap/compiler/compiler.factor
View File

@ -79,7 +79,7 @@ nl
"." write flush
{
malloc free memcpy
malloc calloc free memcpy
} compile
" done" print flush

9
core/bootstrap/primitives.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes tuples
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union compiler.units bootstrap.image.private
io.files ;
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -32,6 +32,9 @@ H{ } clone dictionary set
H{ } clone changed-words set
H{ } clone root-cache set
! Vocabulary for slot accessors
"accessors" create-vocab drop
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
[ drop { } ] recompile-hook set

8
core/combinators/combinators.factor
View File

@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting ;
TUPLE: no-cond ;
: no-cond ( -- * ) \ no-cond construct-empty throw ;
ERROR: no-cond ;
: cond ( assoc -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
TUPLE: no-case ;
: no-case ( -- * ) \ no-case construct-empty throw ;
ERROR: no-case ;
: case ( obj assoc -- )
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip

30
core/debugger/debugger.factor
View File

@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
kernel.private libc ;
kernel.private libc io.encodings ;
IN: debugger
GENERIC: error. ( error -- )
@ -75,9 +75,7 @@ SYMBOL: error-hook
: try ( quot -- )
[ error-hook get call ] recover ;
TUPLE: assert got expect ;
: assert ( got expect -- * ) \ assert construct-boa throw ;
ERROR: assert got expect ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
@ -86,28 +84,22 @@ TUPLE: assert got expect ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] 2apply min tuck tail >r tail r> ;
TUPLE: relative-underflow stack ;
: relative-underflow ( before after -- * )
trim-datastacks nip \ relative-underflow construct-boa throw ;
ERROR: relative-underflow stack ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
TUPLE: relative-overflow stack ;
ERROR: relative-overflow stack ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
: relative-overflow ( before after -- * )
trim-datastacks drop \ relative-overflow construct-boa throw ;
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
{ -1 [ relative-underflow ] }
{ -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] }
{ 1 [ relative-overflow ] }
{ 1 [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
@ -210,13 +202,13 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: check-closed summary
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for create-method" ;
M: check-tuple summary
M: no-tuple-class summary
drop "Invalid class for define-constructor" ;
M: no-cond summary
@ -254,7 +246,7 @@ M: no-compilation-unit error.
M: no-vocab summary
drop "Vocabulary does not exist" ;
M: check-ptr summary
M: bad-ptr summary
drop "Memory allocation failed" ;
M: double-free summary
@ -282,6 +274,10 @@ M: thread error-in-thread ( error thread -- )
] bind
] if ;
M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
<PRIVATE
: init-debugger ( -- )

5
core/definitions/definitions.factor
View File

@ -3,10 +3,7 @@
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
TUPLE: no-compilation-unit definition ;
: no-compilation-unit ( definition -- * )
\ no-compilation-unit construct-boa throw ;
ERROR: no-compilation-unit definition ;
GENERIC: where ( defspec -- loc )

5
core/generic/math/math.factor
View File

@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
dup empty? [ [ dip ] curry [ ] like ] unless
r> append ;
TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ;
ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;

5
core/generic/standard/standard.factor
View File

@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
TUPLE: no-method object generic ;
: no-method ( object generic -- * )
\ no-method construct-boa throw ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;

4
core/inference/inference-tests.factor
View File

@ -514,10 +514,10 @@ DEFER: an-inline-word
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
TUPLE: custom-error ;
ERROR: custom-error ;
[ T{ effect f 0 0 t } ] [
[ custom-error construct-boa throw ] infer
[ custom-error ] infer
] unit-test
: funny-throw throw ; inline

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

@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
\ get-slots [ [get-slots] ] 1 define-transform
TUPLE: duplicated-slots-error names ;
ERROR: duplicated-slots-error names ;
M: duplicated-slots-error summary
drop "Calling set-slots with duplicate slot setters" ;
: duplicated-slots-error ( names -- * )
\ duplicated-slots-error construct-boa throw ;
\ set-slots [
dup all-unique?
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if

8
core/io/encodings/encodings.factor
View File

@ -18,17 +18,13 @@ GENERIC: <decoder> ( stream decoding -- newstream )
TUPLE: decoder stream code cr ;
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
ERROR: decode-error ;
GENERIC: <encoder> ( stream encoding -- newstream )
TUPLE: encoder stream code ;
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
ERROR: encode-error ;
! Decoding

5
core/io/files/files.factor
View File

@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: special-directory? ( name -- ? ) { "." ".." } member? ;
TUPLE: no-parent-directory path ;
: no-parent-directory ( path -- * )
\ no-parent-directory construct-boa throw ;
ERROR: no-parent-directory path ;
: parent-directory ( path -- parent )
right-trim-separators {

5
core/io/streams/duplex/duplex.factor
View File

@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
TUPLE: check-closed ;
ERROR: stream-closed-twice ;
: check-closed ( stream -- )
duplex-stream-closed?
[ \ check-closed construct-boa throw ] when ;
duplex-stream-closed? [ stream-closed-twice ] when ;
: duplex-stream-in+ ( duplex -- stream )
dup check-closed duplex-stream-in ;

14
core/libc/libc.factor
View File

@ -23,20 +23,14 @@ SYMBOL: mallocs
PRIVATE>
TUPLE: check-ptr ;
ERROR: bad-ptr ;
: check-ptr ( c-ptr -- c-ptr )
[ \ check-ptr construct-boa throw ] unless* ;
[ bad-ptr ] unless* ;
TUPLE: double-free ;
ERROR: double-free ;
: double-free ( -- * )
\ double-free construct-empty throw ;
TUPLE: realloc-error ptr size ;
: realloc-error ( alien size -- * )
\ realloc-error construct-boa throw ;
ERROR: realloc-error ptr size ;
<PRIVATE

19
core/parser/parser.factor
View File

@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
: scan ( -- str/f ) lexer get parse-token ;
TUPLE: bad-escape ;
: bad-escape ( -- * )
\ bad-escape construct-empty throw ;
ERROR: bad-escape ;
M: bad-escape summary drop "Bad escape code" ;
@ -215,10 +212,7 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
\ unexpected construct-boa throw ;
ERROR: unexpected want got ;
PREDICATE: unexpected unexpected-eof
unexpected-got not ;
@ -294,10 +288,7 @@ M: no-word summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
\ staging-violation construct-boa throw ;
ERROR: staging-violation word ;
M: staging-violation summary
drop
@ -352,9 +343,7 @@ SYMBOL: lexer-factory
] if
] if ;
TUPLE: bad-number ;
: bad-number ( -- * ) \ bad-number construct-boa throw ;
ERROR: bad-number ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;

12
core/sequences/sequences.factor
View File

@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
TUPLE: bounds-error index seq ;
: bounds-error ( n seq -- * )
\ bounds-error construct-boa throw ;
ERROR: bounds-error index seq ;
: bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline
MIXIN: immutable-sequence
TUPLE: immutable seq ;
: immutable ( seq -- * ) \ immutable construct-boa throw ;
ERROR: immutable seq ;
M: immutable-sequence set-nth immutable ;
@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
: collapse-slice ( m n slice -- m' n' seq )
dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
TUPLE: slice-error reason ;
: slice-error ( str -- * ) \ slice-error construct-boa throw ;
ERROR: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when

95
core/slots/deprecated/deprecated.factor Executable file
View File

@ -0,0 +1,95 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard
classes slots.private combinators slots ;
IN: slots.deprecated
: reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over slot-spec-reader
swap "declared-effect" set-word-prop
slot-spec-reader swap "reading" set-word-prop ;
: define-reader ( class spec -- )
dup slot-spec-reader [
[ set-reader-props ] 2keep
dup slot-spec-offset
over slot-spec-reader
rot slot-spec-type reader-quot
define-slot-word
] [
2drop
] if ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over slot-spec-writer
swap "declared-effect" set-word-prop
slot-spec-writer swap "writing" set-word-prop ;
: define-writer ( class spec -- )
dup slot-spec-writer [
[ set-writer-props ] 2keep
dup slot-spec-offset
swap slot-spec-writer
[ set-slot ]
define-slot-word
] [
2drop
] if ;
: define-slot ( class spec -- )
2dup define-reader define-writer ;
: define-slots ( class specs -- )
[ define-slot ] with each ;
: reader-word ( class name vocab -- word )
>r >r "-" r> 3append r> create ;
: writer-word ( class name vocab -- word )
>r [ swap "set-" % % "-" % % ] "" make r> create ;
: (simple-slot-word) ( class name -- class name vocab )
over word-vocabulary >r >r word-name r> r> ;
: simple-reader-word ( class name -- word )
(simple-slot-word) reader-word ;
: simple-writer-word ( class name -- word )
(simple-slot-word) writer-word ;
: short-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: long-slot ( spec # -- spec )
>r [ dup array? [ first2 create ] when ] map first4 r>
-rot <slot-spec> ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map [
{
{ [ over not ] [ 2drop f ] }
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] subset nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;

61
core/slots/slots-docs.factor Normal file → Executable file
View File

@ -12,15 +12,11 @@ $nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
{ $subsection slot-spec-reader }
{ $subsection slot-spec-writer }
"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
{ $subsection slot-of-reader }
{ $subsection slot-of-writer }
"Reader and writer words form classes:"
{ $subsection slot-reader }
{ $subsection slot-writer }
"Slot readers and writers type check, then call unsafe primitives:"
{ $subsection reader-word }
{ $subsection writer-word }
{ $subsection setter-word }
{ $subsection changer-word }
"Slot methods type check, then call unsafe primitives:"
{ $subsection slot }
{ $subsection set-slot } ;
@ -59,17 +55,7 @@ $low-level-note ;
HELP: reader-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
HELP: reader-quot
{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
HELP: slot-reader
{ $class-description "The class of slot reader words." }
{ $examples
{ $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
} ;
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
{ $values { "class" class } { "spec" slot-spec } }
@ -80,32 +66,21 @@ HELP: writer-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: slot-writer
{ $class-description "The class of slot writer words." }
{ $examples
{ $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
} ;
HELP: define-writer
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slot
HELP: define-slot-methods
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slots
HELP: define-accessors
{ $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Defines a set of slot reader/writer words." }
{ $description "Defines slot methods." }
$low-level-note ;
HELP: simple-slots
{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
HELP: slot ( obj m -- value )
{ $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
{ $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
@ -116,18 +91,6 @@ HELP: set-slot ( value obj n -- )
{ $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
HELP: slot-of-reader
{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
HELP: slot-of-writer
{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
HELP: reader-word
{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
HELP: writer-word
{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
HELP: slot-named
{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
{ $description "Outputs the " { $link slot-spec } " with the given name." } ;

146
core/slots/slots.factor
View File

@ -16,9 +16,6 @@ C: <slot-spec> slot-spec
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
: reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ;
: reader-quot ( decl -- quot )
[
\ slot ,
@ -26,91 +23,62 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
PREDICATE: word slot-reader "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
over slot-spec-reader
swap "declared-effect" set-word-prop
slot-spec-reader swap "reading" set-word-prop ;
: define-reader ( class spec -- )
dup slot-spec-reader [
[ set-reader-props ] 2keep
dup slot-spec-offset
over slot-spec-reader
rot slot-spec-type reader-quot
define-slot-word
] [
2drop
] if ;
: writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ;
PREDICATE: word slot-writer "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
over slot-spec-writer
swap "declared-effect" set-word-prop
slot-spec-writer swap "writing" set-word-prop ;
: define-writer ( class spec -- )
dup slot-spec-writer [
[ set-writer-props ] 2keep
dup slot-spec-offset
swap slot-spec-writer
[ set-slot ]
define-slot-word
] [
2drop
] if ;
: define-slot ( class spec -- )
2dup define-reader define-writer ;
: define-slots ( class specs -- )
[ define-slot ] with each ;
: reader-word ( class name vocab -- word )
>r >r "-" r> 3append r> create ;
: writer-word ( class name vocab -- word )
>r [ swap "set-" % % "-" % % ] "" make r> create ;
: (simple-slot-word) ( class name -- class name vocab )
over word-vocabulary >r >r word-name r> r> ;
: simple-reader-word ( class name -- word )
(simple-slot-word) reader-word ;
: simple-writer-word ( class name -- word )
(simple-slot-word) writer-word ;
: short-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: long-slot ( spec # -- spec )
>r [ dup array? [ first2 create ] when ] map first4 r>
-rot <slot-spec> ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map [
{
{ [ over not ] [ 2drop f ] }
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] subset nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
: slot-named ( string specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-effect T{ effect f { "object" } { "value" } } ; inline
: reader-word ( name -- word )
">>" append reader-effect create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
: writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word )
"(>>" swap ")" 3append writer-effect create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
"change-" prepend changer-effect create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
[ r> call r> swap ] %
swap setter-word ,
] [ ] make define-inline
] [ 2drop ] if ;
: define-slot-methods ( class slot name -- )
dup define-changer
dup define-setter
3dup define-reader
define-writer ;
: define-accessors ( class specs -- )
[
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;

7
core/syntax/syntax-docs.factor
View File

@ -560,6 +560,13 @@ HELP: TUPLE:
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }

1
core/syntax/syntax.factor
View File

@ -165,6 +165,7 @@ IN: bootstrap.syntax
"ERROR:" [
CREATE-CLASS dup ";" parse-tokens define-tuple-class
dup save-location
dup [ construct-boa throw ] curry define
] define-syntax

2
core/tuples/tuples-tests.factor
View File

@ -236,7 +236,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with
] [ [ no-tuple-class? ] is? ] must-fail-with
! Hardcore unit tests
USE: threads

10
core/tuples/tuples.factor
View File

@ -3,7 +3,8 @@
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.private compiler.units ;
classes classes.private slots slots.deprecated slots.private
compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
@ -85,13 +86,14 @@ PRIVATE>
dupd 4 simple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop
define-slots ;
2dup define-slots
define-accessors ;
TUPLE: check-tuple class ;
ERROR: no-tuple-class class ;
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ \ check-tuple construct-boa throw ] if ;
[ drop ] [ no-tuple-class ] if ;
: define-tuple-class ( class slots -- )
2dup check-shape

10
core/vocabs/vocabs.factor
View File

@ -7,8 +7,7 @@ IN: vocabs
SYMBOL: dictionary
TUPLE: vocab
name root
words
name words
main help
source-loaded? docs-loaded? ;
@ -60,16 +59,13 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
TUPLE: no-vocab name ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ no-vocab ] ?if ;
dup vocab [ ] [ vocab-name no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;

11
core/words/words.factor
View File

@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
M: word definition word-def ;
TUPLE: undefined ;
: undefined ( -- * ) \ undefined construct-empty throw ;
ERROR: undefined ;
PREDICATE: word deferred ( obj -- ? )
word-def [ undefined ] = ;
@ -189,12 +187,11 @@ M: word subwords drop f ;
[ ] [ no-vocab ] ?if
set-at ;
TUPLE: check-create name vocab ;
ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
2dup [ string? ] both? [
\ check-create construct-boa throw
] unless ;
2dup [ string? ] both?
[ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup

2
extra/cairo/lib/lib.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math combinators.cleave shuffle new-slots
kernel libc locals math combinators.cleave shuffle
accessors ;
IN: cairo.lib

2
extra/cairo/png/png.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.cleave kernel new-slots
USING: arrays combinators.cleave kernel
accessors math ui.gadgets ui.render opengl.gl byte-arrays
namespaces opengl cairo.ffi cairo.lib ;
IN: cairo.png

2
extra/calendar/calendar.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel math math.functions namespaces sequences
strings tuples system vocabs.loader calendar.backend threads
new-slots accessors combinators locals ;
accessors combinators locals ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;

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

@ -3,7 +3,7 @@
USING: serialize sequences concurrency.messaging
threads io io.server qualified arrays
namespaces kernel io.encodings.binary combinators.cleave
new-slots accessors ;
accessors ;
QUALIFIED: io.sockets
IN: concurrency.distributed

2
extra/db/db.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings
tools.walker new-slots accessors ;
tools.walker accessors ;
IN: db
TUPLE: db

2
extra/db/postgresql/lib/lib.factor
View File

@ -4,7 +4,7 @@ USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser
combinators combinators.cleave libc shuffle calendar.format
byte-arrays destructors prettyprint new-slots accessors
byte-arrays destructors prettyprint accessors
strings serialize io.encodings.binary io.streams.byte-array ;
IN: db.postgresql.lib

2
extra/digraphs/digraphs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel new-slots sequences vectors ;
USING: accessors assocs kernel sequences vectors ;
IN: digraphs
TUPLE: digraph ;

4
extra/help/help.factor
View File

@ -25,10 +25,6 @@ GENERIC: word-help* ( word -- content )
M: word word-help* drop f ;
M: slot-reader word-help* drop \ $slot-reader ;
M: slot-writer word-help* drop \ $slot-writer ;
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )

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

@ -296,63 +296,6 @@ M: string ($instance)
{ $link with-pprint } " combinator."
} $notes ;
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
[ { $instance } swap add ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
over [
2dup $spec-reader-values
2dup $spec-reader-description
] when 2drop ;
GENERIC: slot-specs ( help-type -- specs )
M: word slot-specs "slots" word-prop ;
: $slot-reader ( reader -- )
first dup "reading" word-prop [ slot-specs ] keep
$spec-reader ;
: $spec-writer-values ( slot-spec class -- )
($spec-reader-values) reverse $values ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
{ $snippet } rot slot-spec-name add ,
" slot of " ,
{ $instance } swap add ,
" instance." ,
] { } make $description ;
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
over [
2dup $spec-writer-values
2dup $spec-writer-description
dup ?word-name 1array $side-effects
] when 2drop ;
: $slot-writer ( reader -- )
first dup "writing" word-prop [ slot-specs ] keep
$spec-writer ;
GENERIC: elements* ( elt-type element -- )
M: simple-element elements* [ elements* ] with each ;

2
extra/http/http.factor
View File

@ -3,7 +3,7 @@
USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
combinators vectors sorting accessors calendar
calendar.format quotations arrays combinators.cleave
combinators.lib byte-arrays ;
IN: http

2
extra/http/server/actions/actions.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
USING: accessors sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations locals ;
IN: http.server.actions

2
extra/http/server/auth/basic/basic.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots quotations assocs kernel splitting
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http sequences ;

2
extra/http/server/auth/login/login.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots quotations assocs kernel splitting
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http.server.actions http.server.components http.server.sessions

2
extra/http/server/auth/providers/assoc/assoc.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
USING: accessors assocs kernel
http.server.auth.providers ;
TUPLE: users-in-memory assoc ;

2
extra/http/server/auth/providers/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types new-slots accessors
USING: db db.tuples db.types accessors
http.server.auth.providers kernel continuations
singleton ;
IN: http.server.auth.providers.db

2
extra/http/server/auth/providers/providers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel new-slots accessors random math.parser locals
USING: kernel accessors random math.parser locals
sequences math crypto.sha2 ;
IN: http.server.auth.providers

2
extra/http/server/callbacks/callbacks.factor
View File

@ -2,7 +2,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
continuations calendar sequences assocs hashtables
accessors arrays alarms quotations combinators
combinators.cleave fry assocs.lib ;
IN: http.server.callbacks

2
extra/http/server/components/components-tests.factor
View File

@ -1,6 +1,6 @@
IN: http.server.components.tests
USING: http.server.components http.server.validators
namespaces tools.test kernel accessors new-slots
namespaces tools.test kernel accessors
tuple-syntax mirrors http.server.actions ;
validation-failed? off

2
extra/http/server/components/components.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: new-slots html.elements http.server.validators accessors
USING: html.elements http.server.validators accessors
namespaces kernel io math.parser assocs classes words tuples
arrays sequences io.files http.server.templating.fhtml
http.server.actions splitting mirrors hashtables

2
extra/http/server/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db http.server kernel new-slots accessors
USING: db http.server kernel accessors
continuations namespaces destructors combinators.cleave ;
IN: http.server.db

2
extra/http/server/server-tests.factor
View File

@ -1,5 +1,5 @@
USING: http.server tools.test kernel namespaces accessors
new-slots io http math sequences assocs ;
io http math sequences assocs ;
IN: http.server.tests
[

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server

2
extra/http/server/sessions/sessions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
new-slots accessors http http.server
accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
html.elements symbols continuations destructors ;

2
extra/http/server/sessions/storage/assoc/assoc.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib new-slots accessors
USING: assocs assocs.lib accessors
http.server.sessions.storage combinators.cleave alarms kernel
fry http.server ;
IN: http.server.sessions.storage.assoc

2
extra/http/server/sessions/storage/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs new-slots accessors http.server.sessions.storage
USING: assocs accessors http.server.sessions.storage
alarms kernel http.server db.tuples db.types singleton
combinators.cleave math.parser ;
IN: http.server.sessions.storage.db

2
extra/http/server/static/static.factor
View File

@ -3,7 +3,7 @@
USING: calendar html io io.files kernel math math.parser http
http.server namespaces parser sequences strings assocs
hashtables debugger http.mime sorting html.elements logging
calendar.format new-slots accessors io.encodings.binary
calendar.format accessors io.encodings.binary
combinators.cleave fry ;
IN: http.server.static

2
extra/http/server/validators/validators.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces
math.parser assocs new-slots regexp fry unicode.categories
math.parser assocs regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators

4
extra/io/encodings/utf16/utf16.factor
View File

@ -18,13 +18,13 @@ TUPLE: utf16 ;
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
: double-be ( stream byte -- stream char )
over stream-read1 prepend-nums ;
over stream-read1 swap append-nums ;
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
over stream-read1 prepend-nums HEX: 10000 +
over stream-read1 swap append-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;

2
extra/io/launcher/launcher.factor
View File

@ -3,7 +3,7 @@
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
io.nonblocking new-slots accessors ;
io.nonblocking accessors ;
IN: io.launcher

2
extra/io/paths/paths.factor
View File

@ -1,4 +1,4 @@
USING: io.files kernel sequences new-slots accessors
USING: io.files kernel sequences accessors
dlists arrays sequences.lib ;
IN: io.paths

2
extra/io/unix/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
io.unix.launcher.parser io.encodings.latin1 accessors ;
IN: io.unix.launcher
! Search unix first

2
extra/io/windows/launcher/launcher.factor
View File

@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
io.backend new-slots accessors concurrency.flags ;
io.backend accessors concurrency.flags ;
IN: io.windows.launcher
TUPLE: CreateProcess-args

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

@ -3,7 +3,7 @@
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random
combinators new-slots accessors ;
combinators accessors ;
IN: io.windows.nt.pipes
! This code is based on

2
extra/locals/locals.factor
View File

@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic
compiler.units combinators.cleave new-slots accessors ;
compiler.units combinators.cleave accessors ;
IN: locals
! Inspired by

32
extra/peg/ebnf/ebnf-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf compiler.units ;
USING: kernel tools.test peg peg.ebnf ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@ -109,13 +109,37 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "a" "b" } } [
"foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
"ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast
] unit-test
{ V{ 1 "b" } } [
"foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
"ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast
] unit-test
{ V{ 1 2 } } [
"foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
"ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast
] unit-test
{ CHAR: A } [
"A" [EBNF foo=[A-Z] EBNF] call parse-result-ast
] unit-test
{ CHAR: Z } [
"Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast
] unit-test
{ f } [
"0" [EBNF foo=[A-Z] EBNF] call
] unit-test
{ CHAR: 0 } [
"0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast
] unit-test
{ f } [
"A" [EBNF foo=[^A-Z] EBNF] call
] unit-test
{ f } [
"Z" [EBNF foo=[^A-Z] EBNF] call
] unit-test

231
extra/peg/ebnf/ebnf.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
splitting ;
@ -9,6 +9,8 @@ IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-any-character ;
TUPLE: ebnf-range pattern ;
TUPLE: ebnf-ensure group ;
TUPLE: ebnf-ensure-not group ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
@ -22,6 +24,8 @@ TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-any-character> ebnf-any-character
C: <ebnf-range> ebnf-range
C: <ebnf-ensure> ebnf-ensure
C: <ebnf-ensure-not> ebnf-ensure-not
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
@ -32,84 +36,6 @@ C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
: reset-parser-generation ( -- )
V{ } clone parsers set
H{ } clone non-terminals set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser )
parsers get nth ;
: non-terminal-index ( name -- number )
dup non-terminals get at [
nip
] [
f store-parser [ swap non-terminals get set-at ] keep
] if* ;
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
(generate-parser) ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id )
[
ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
M: ebnf-any-character (generate-parser) ( ast -- id )
drop [ drop t ] satisfy store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [
generate-parser get-parser
] map seq store-parser ;
M: ebnf-ensure-not (generate-parser) ( ast -- id )
ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-repeat1 (generate-parser) ( ast -- id )
ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
[ ebnf-action-parser generate-parser get-parser ] keep
ebnf-action-code string-lines parse-lines action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
] map peek ;
DEFER: 'rhs'
: syntax ( string -- parser )
#! Parses the string, ignoring white space, and
#! does not put the result in the AST.
@ -149,6 +75,7 @@ DEFER: 'rhs'
[ dup CHAR: [ = ]
[ dup CHAR: . = ]
[ dup CHAR: ! = ]
[ dup CHAR: & = ]
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
@ -163,6 +90,14 @@ DEFER: 'rhs'
: 'any-character' ( -- parser )
#! A parser to match the symbol for any character match.
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
: 'range-parser' ( -- parser )
#! Match the syntax for declaring character ranges
[
[ "[" syntax , "[" token ensure-not , ] seq* hide ,
[ CHAR: ] = not ] satisfy repeat1 ,
"]" syntax ,
] seq* [ first >string <ebnf-range> ] action ;
: 'element' ( -- parser )
#! An element of a rule. It can be a terminal or a
@ -173,6 +108,7 @@ DEFER: 'rhs'
[
'non-terminal' ,
'terminal' ,
'range-parser' ,
'any-character' ,
] choice* ,
"=" syntax ensure-not ,
@ -194,7 +130,6 @@ DEFER: 'choice'
"*" token sp ensure-not ,
"+" token sp ensure-not ,
"?" token sp ensure-not ,
"[[" token sp ensure-not ,
] seq* hide grouped ;
: 'repeat0' ( -- parser )
@ -212,13 +147,6 @@ DEFER: 'choice'
[ drop t ] satisfy ,
] seq* [ first ] action repeat0 [ >string ] action ;
: 'action' ( -- parser )
[
"(" [ 'choice' sp ] delay ")" syntax-pack ,
"[[" 'factor-code' "]]" syntax-pack ,
] seq* [ first2 <ebnf-action> ] action ;
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
#! something that matches the following elements do
@ -228,21 +156,41 @@ DEFER: 'choice'
'group' sp ,
] seq* [ first <ebnf-ensure-not> ] action ;
: 'sequence' ( -- parser )
: 'ensure' ( -- parser )
#! Parses the '&' syntax to ensure that
#! something that matches the following elements does
#! exist in the parse stream.
[
"&" syntax ,
'group' sp ,
] seq* [ first <ebnf-ensure> ] action ;
: ('sequence') ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
'ensure-not' sp ,
'ensure' sp ,
'element' sp ,
'group' sp ,
'repeat0' sp ,
'repeat1' sp ,
'optional' sp ,
'action' sp ,
] choice* ;
: 'sequence' ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
[
('sequence') ,
"[[" 'factor-code' "]]" syntax-pack ,
] seq* [ first2 <ebnf-action> ] action ,
('sequence') ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
@ -258,25 +206,84 @@ DEFER: 'choice'
: 'ebnf' ( -- parser )
'rule' sp repeat1 [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
parse-result-ast [
reset-parser-generation
generate-parser drop
[
non-terminals get
[
get-parser [
swap , \ in , \ get , \ create ,
1quotation , \ define ,
] [
drop
] if*
] assoc-each
] [ ] make
] with-scope
] [
f
] if* ;
GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
: transform ( ast -- object )
H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser )
ebnf-rules [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser )
dup ebnf-rule-elements (transform) [
swap ebnf-rule-symbol set
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
ebnf-sequence-elements [ (transform) ] map seq ;
M: ebnf-choice (transform) ( ast -- parser )
ebnf-choice-options [ (transform) ] map choice ;
M: ebnf-any-character (transform) ( ast -- parser )
drop any-char ;
M: ebnf-range (transform) ( ast -- parser )
ebnf-range-pattern range-pattern ;
M: ebnf-ensure (transform) ( ast -- parser )
ebnf-ensure-group (transform) ensure ;
M: ebnf-ensure-not (transform) ( ast -- parser )
ebnf-ensure-not-group (transform) ensure-not ;
M: ebnf-repeat0 (transform) ( ast -- parser )
ebnf-repeat0-group (transform) repeat0 ;
M: ebnf-repeat1 (transform) ( ast -- parser )
ebnf-repeat1-group (transform) repeat1 ;
M: ebnf-optional (transform) ( ast -- parser )
ebnf-optional-elements (transform) optional ;
M: ebnf-action (transform) ( ast -- parser )
[ ebnf-action-parser (transform) ] keep
ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-terminal (transform) ( ast -- parser )
ebnf-terminal-symbol token sp ;
M: ebnf-non-terminal (transform) ( ast -- parser )
ebnf-non-terminal-symbol [
, parser get , \ at ,
] [ ] make delay sp ;
: transform-ebnf ( string -- object )
'ebnf' parse parse-result-ast transform ;
: check-parse-result ( result -- result )
dup [
dup parse-result-remaining empty? [
[
"Unable to fully parse EBNF. Left to parse was: " %
parse-result-remaining %
] "" make throw
] unless
] [
"Could not parse EBNF" throw
] if ;
: ebnf>quot ( string -- hashtable quot )
'ebnf' parse check-parse-result
parse-result-ast transform dup main swap at compile ;
: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
";EBNF" parse-multiline-string
ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing

25
extra/peg/expr/expr-tests.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.expr multiline sequences ;
IN: peg.expr.tests
{ 5 } [
"2+3" eval-expr
] unit-test
{ 6 } [
"2*3" eval-expr
] unit-test
{ 14 } [
"2+3*4" eval-expr
] unit-test
{ 17 } [
"2+3*4+3" eval-expr
] unit-test
{ 23 } [
"2+3*(4+3)" eval-expr
] unit-test

21
extra/peg/expr/expr.factor
View File

@ -9,22 +9,21 @@ IN: peg.expr
#! { operator rhs } in to a tree structure of the correct precedence.
swap [ first2 swap call ] reduce ;
<EBNF
EBNF: expr
times = "*" [[ drop [ * ] ]]
divide = "/" [[ drop [ / ] ]]
add = "+" [[ drop [ + ] ]]
subtract = "-" [[ drop [ - ] ]]
times = ("*") [[ drop [ * ] ]]
divide = ("/") [[ drop [ / ] ]]
add = ("+") [[ drop [ + ] ]]
subtract = ("-") [[ drop [ - ] ]]
digit = "0" | "1" | "2" | "3" | "4" |
"5" | "6" | "7" | "8" | "9"
number = ((digit)+) [[ concat string>number ]]
digit = [0-9] [[ digit> ]]
number = (digit)+ [[ unclip [ swap 10 * + ] reduce ]]
value = number | ("(" expr ")") [[ second ]]
product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]]
expr = sum
EBNF>
;EBNF
: eval-expr ( string -- number )
expr parse parse-result-ast ;
expr parse-result-ast ;

18
extra/peg/parsers/parsers-docs.factor
View File

@ -159,3 +159,21 @@ HELP: 'string'
} { $description
"Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
} { $see-also 'integer' } ;
HELP: range-pattern
{ $values
{ "pattern" "a string" }
{ "parser" "a parser" }
} { $description
"Returns a parser that matches a single character based on the set "
"of characters in the pattern string."
"Any single character in the pattern matches that character. "
"If the pattern begins with a ^ then the set is negated "
"(the element matches any character not in the set). Any pair "
"of characters separated with a dash (-) represents the "
"range of characters from the first to the second, inclusive."
{ $examples
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
{ $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" }
}
} ;

66
extra/peg/parsers/parsers.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match
unicode.categories sequences.deep peg peg.private ;
vectors arrays combinators.lib math.parser match
unicode.categories sequences.deep peg peg.private
peg.search math.ranges ;
IN: peg.parsers
TUPLE: just-parser p1 ;
@ -18,26 +19,26 @@ TUPLE: just-parser p1 ;
M: just-parser compile ( parser -- quot )
just-parser-p1 compile just-pattern append ;
MEMO: just ( parser -- parser )
just-parser construct-boa init-parser ;
: just ( parser -- parser )
just-parser construct-boa ;
MEMO: 1token ( ch -- parser ) 1string token ;
: 1token ( ch -- parser ) 1string token ;
<PRIVATE
MEMO: (list-of) ( items separator repeat1? -- parser )
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
PRIVATE>
MEMO: list-of ( items separator -- parser )
: list-of ( items separator -- parser )
hide f (list-of) ;
MEMO: list-of-many ( items separator -- parser )
: list-of-many ( items separator -- parser )
hide t (list-of) ;
MEMO: epsilon ( -- parser ) V{ } token ;
: epsilon ( -- parser ) V{ } token ;
MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
: any-char ( -- parser ) [ drop t ] satisfy ;
<PRIVATE
@ -46,10 +47,10 @@ MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
PRIVATE>
MEMO: exactly-n ( parser n -- parser' )
: exactly-n ( parser n -- parser' )
swap <repetition> seq ;
MEMO: at-most-n ( parser n -- parser' )
: at-most-n ( parser n -- parser' )
dup zero? [
2drop epsilon
] [
@ -57,29 +58,56 @@ MEMO: at-most-n ( parser n -- parser' )
-rot 1- at-most-n 2choice
] if ;
MEMO: at-least-n ( parser n -- parser' )
: at-least-n ( parser n -- parser' )
dupd exactly-n swap repeat0 2seq
[ flatten-vectors ] action ;
MEMO: from-m-to-n ( parser m n -- parser' )
: from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n 2seq
[ flatten-vectors ] action ;
MEMO: pack ( begin body end -- parser )
: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ;
MEMO: surrounded-by ( parser begin end -- parser' )
: surrounded-by ( parser begin end -- parser' )
[ token ] 2apply swapd pack ;
MEMO: 'digit' ( -- parser )
: 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] action ;
MEMO: 'integer' ( -- parser )
: 'integer' ( -- parser )
'digit' repeat1 [ 10 digits>integer ] action ;
MEMO: 'string' ( -- parser )
: 'string' ( -- parser )
[
[ CHAR: " = ] satisfy hide ,
[ CHAR: " = not ] satisfy repeat0 ,
[ CHAR: " = ] satisfy hide ,
] { } make seq [ first >string ] action ;
: (range-pattern) ( pattern -- string )
#! Given a range pattern, produce a string containing
#! all characters within that range.
[
any-char ,
[ CHAR: - = ] satisfy hide ,
any-char ,
] seq* [
first2 [a,b] >string
] action
replace ;
: range-pattern ( pattern -- parser )
#! 'pattern' is a set of characters describing the
#! parser to be produced. Any single character in
#! the pattern matches that character. If the pattern
#! begins with a ^ then the set is negated (the element
#! matches any character not in the set). Any pair of
#! characters separated with a dash (-) represents the
#! range of characters from the first to the second,
#! inclusive.
dup first CHAR: ^ = [
1 tail (range-pattern) [ member? not ] curry satisfy
] [
(range-pattern) [ member? ] curry satisfy
] if ;

4
extra/peg/peg-tests.factor
View File

@ -4,10 +4,6 @@
USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
IN: peg.tests
{ 0 1 2 } [
0 next-id set-global get-next-id get-next-id get-next-id
] unit-test
{ f } [
"endbegin" "begin" token parse
] unit-test

106
extra/peg/peg.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words ;
IN: peg
@ -10,70 +10,14 @@ TUPLE: parse-result remaining ast ;
GENERIC: compile ( parser -- quot )
: (parse) ( state parser -- result )
: parse ( state parser -- result )
compile call ;
<PRIVATE
SYMBOL: packrat-cache
SYMBOL: ignore
SYMBOL: not-in-cache
: not-in-cache? ( result -- ? )
not-in-cache = ;
: <parse-result> ( remaining ast -- parse-result )
parse-result construct-boa ;
SYMBOL: next-id
: get-next-id ( -- number )
next-id get-global 0 or dup 1+ next-id set-global ;
TUPLE: parser id ;
: init-parser ( parser -- parser )
get-next-id parser construct-boa over set-delegate ;
: from ( slice-or-string -- index )
dup slice? [ slice-from ] [ drop 0 ] if ;
: get-cached ( input parser -- result )
[ from ] dip parser-id packrat-cache get at at* [
drop not-in-cache
] unless ;
: put-cached ( result input parser -- )
parser-id dup packrat-cache get at [
nip
] [
H{ } clone dup >r swap packrat-cache get set-at r>
] if*
[ from ] dip set-at ;
PRIVATE>
: parse ( input parser -- result )
packrat-cache get [
2dup get-cached dup not-in-cache? [
! "cache missed: " write over parser-id number>string write " - " write nl ! pick .
drop
#! Protect against left recursion blowing the callstack
#! by storing a failed parse in the cache.
[ f ] dipd [ put-cached ] 2keep
[ (parse) dup ] 2keep put-cached
] [
! "cache hit: " write over parser-id number>string write " - " write nl ! pick .
2nip
] if
] [
(parse)
] if ;
: packrat-parse ( input parser -- result )
H{ } clone packrat-cache [ parse ] with-variable ;
<PRIVATE
TUPLE: token-parser symbol ;
@ -295,17 +239,17 @@ M: delay-parser compile ( parser -- quot )
PRIVATE>
MEMO: token ( string -- parser )
token-parser construct-boa init-parser ;
: token ( string -- parser )
token-parser construct-boa ;
: satisfy ( quot -- parser )
satisfy-parser construct-boa init-parser ;
satisfy-parser construct-boa ;
MEMO: range ( min max -- parser )
range-parser construct-boa init-parser ;
: range ( min max -- parser )
range-parser construct-boa ;
: seq ( seq -- parser )
seq-parser construct-boa init-parser ;
seq-parser construct-boa ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
@ -320,7 +264,7 @@ MEMO: range ( min max -- parser )
{ } make seq ; inline
: choice ( seq -- parser )
choice-parser construct-boa init-parser ;
choice-parser construct-boa ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
@ -334,32 +278,32 @@ MEMO: range ( min max -- parser )
: choice* ( quot -- paser )
{ } make choice ; inline
MEMO: repeat0 ( parser -- parser )
repeat0-parser construct-boa init-parser ;
: repeat0 ( parser -- parser )
repeat0-parser construct-boa ;
MEMO: repeat1 ( parser -- parser )
repeat1-parser construct-boa init-parser ;
: repeat1 ( parser -- parser )
repeat1-parser construct-boa ;
MEMO: optional ( parser -- parser )
optional-parser construct-boa init-parser ;
: optional ( parser -- parser )
optional-parser construct-boa ;
MEMO: ensure ( parser -- parser )
ensure-parser construct-boa init-parser ;
: ensure ( parser -- parser )
ensure-parser construct-boa ;
MEMO: ensure-not ( parser -- parser )
ensure-not-parser construct-boa init-parser ;
: ensure-not ( parser -- parser )
ensure-not-parser construct-boa ;
: action ( parser quot -- parser )
action-parser construct-boa init-parser ;
action-parser construct-boa ;
MEMO: sp ( parser -- parser )
sp-parser construct-boa init-parser ;
: sp ( parser -- parser )
sp-parser construct-boa ;
MEMO: hide ( parser -- parser )
: hide ( parser -- parser )
[ drop ignore ] action ;
MEMO: delay ( quot -- parser )
delay-parser construct-boa init-parser ;
: delay ( quot -- parser )
delay-parser construct-boa ;
: PEG:
(:) [

12
extra/peg/pl0/pl0-tests.factor
View File

@ -4,14 +4,6 @@
USING: kernel tools.test peg peg.pl0 multiline sequences ;
IN: peg.pl0.tests
{ "abc" } [
"abc" ident parse parse-result-ast
] unit-test
{ 55 } [
"55abc" number parse parse-result-ast
] unit-test
{ t } [
<"
VAR x, squ;
@ -29,7 +21,7 @@ BEGIN
x := x + 1;
END
END.
"> program parse parse-result-remaining empty?
"> pl0 parse-result-remaining empty?
] unit-test
{ f } [
@ -95,5 +87,5 @@ BEGIN
y := 36;
CALL gcd;
END.
"> program parse parse-result-remaining empty?
"> pl0 parse-result-remaining empty?
] unit-test

35
extra/peg/pl0/pl0.factor
View File

@ -1,31 +1,26 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences
peg peg.ebnf peg.parsers memoize namespaces ;
peg peg.ebnf peg.parsers memoize namespaces math ;
IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
MEMO: ident ( -- parser )
[
CHAR: a CHAR: z range ,
CHAR: A CHAR: Z range ,
] choice* repeat1 [ >string ] action ;
MEMO: number ( -- parser )
CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
<EBNF
program = block "."
block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
[ "VAR" ident { "," ident } ";" ]
{ "PROCEDURE" ident ";" [ block ";" ] } statement
statement = [ ident ":=" expression | "CALL" ident |
"BEGIN" statement {";" statement } "END" |
EBNF: pl0
block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
( "VAR" ident ( "," ident )* ";" )?
( "PROCEDURE" ident ";" ( block ";" )? )* statement
statement = ( ident ":=" expression | "CALL" ident |
"BEGIN" statement (";" statement )* "END" |
"IF" condition "THEN" statement |
"WHILE" condition "DO" statement ]
"WHILE" condition "DO" statement )?
condition = "ODD" expression |
expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
expression = ["+" | "-"] term {("+" | "-") term }
term = factor {("*" | "/") factor }
expression = ("+" | "-")? term (("+" | "-") term )*
term = factor (("*" | "/") factor )*
factor = ident | number | "(" expression ")"
EBNF>
ident = (([a-zA-Z])+) [[ >string ]]
digit = ([0-9]) [[ digit> ]]
number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
program = block "."
;EBNF

2
extra/random/blum-blum-shub/blum-blum-shub.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: kernel math sequences namespaces
math.miller-rabin combinators.cleave combinators.lib
math.functions new-slots accessors random ;
math.functions accessors random ;
IN: random.blum-blum-shub
! TODO: take (log log M) bits instead of 1 bit

2
extra/random/dummy/dummy.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: kernel random math new-slots accessors ;
USING: kernel random math accessors ;
IN: random.dummy
TUPLE: random-dummy i ;

2
extra/random/mersenne-twister/mersenne-twister.factor
View File

@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
new-slots accessors math.ranges combinators.cleave random ;
accessors math.ranges combinators.cleave random ;
IN: random.mersenne-twister
<PRIVATE

2
extra/semantic-db/hierarchy/hierarchy.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors db.tuples hashtables kernel new-slots
USING: accessors db.tuples hashtables kernel
semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy

2
extra/semantic-db/semantic-db.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
IN: semantic-db
TUPLE: node id content ;

2
extra/serialize/serialize.factor
View File

@ -11,7 +11,7 @@ io.binary strings classes words sbufs tuples arrays vectors
byte-arrays bit-arrays quotations hashtables assocs help.syntax
help.markup float-arrays splitting io.streams.byte-array
io.encodings.string io.encodings.utf8 io.encodings.binary
combinators combinators.cleave new-slots accessors locals
combinators combinators.cleave accessors locals
prettyprint compiler.units sequences.private tuples.private ;
IN: serialize

20
extra/smtp/smtp.factor
View File

@ -4,11 +4,11 @@
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii
calendar.format new-slots accessors ;
calendar.format accessors ;
IN: smtp
SYMBOL: smtp-domain
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global
@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
: crlf "\r\n" write ;
: command ( string -- ) write crlf flush ;
: helo ( -- )
esmtp get "EHLO " "HELO " ? write host-name write crlf ;
esmtp get "EHLO " "HELO " ? host-name append command ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
[ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ;
"MAIL FROM:<" swap validate-address ">" 3append command ;
: rcpt-to ( to -- )
"RCPT TO:<" write validate-address write ">" write crlf ;
"RCPT TO:<" swap validate-address ">" 3append command ;
: data ( -- )
"DATA" write crlf ;
"DATA" command ;
: validate-message ( msg -- msg' )
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
string-lines
validate-message
[ write crlf ] each
"." write crlf ;
"." command ;
: quit ( -- )
"QUIT" write crlf ;
"QUIT" command ;
LOG: smtp-response DEBUG
@ -85,7 +87,7 @@ LOG: smtp-response DEBUG
readln
dup multiline? [ 3 head process-multiline ] when ;
: get-ok ( -- ) flush receive-response check-response ;
: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
dup "\r\n" seq-intersect empty?

4
extra/tools/deploy/shaker/shaker.factor
View File

@ -19,7 +19,7 @@ QUALIFIED: libc.private
QUALIFIED: libc.private
QUALIFIED: listener
QUALIFIED: prettyprint.config
QUALIFIED: random.private
QUALIFIED: random
QUALIFIED: source-files
QUALIFIED: threads
QUALIFIED: vocabs
@ -108,7 +108,7 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq )
[
random.private:mt ,
random:random-generator ,
{
bootstrap.stage2:bootstrap-time

1
extra/tools/vocabs/vocabs.factor
View File

@ -108,6 +108,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
?resource-path utf8 set-file-lines
\ (vocab-file-contents) reset-memoized
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"

2
extra/windows/com/syntax/syntax.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types kernel windows.ole32
combinators.lib parser splitting sequences.lib
sequences namespaces new-slots combinators.cleave
sequences namespaces combinators.cleave
assocs quotations shuffle accessors words macros
alien.syntax fry ;
IN: windows.com.syntax