Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
7513cd774b
|
|
@ -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,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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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,7 +86,8 @@ 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 ;
|
||||
|
||||
ERROR: no-tuple-class class ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,8 +7,7 @@ IN: vocabs
|
|||
SYMBOL: dictionary
|
||||
|
||||
TUPLE: vocab
|
||||
name root
|
||||
words
|
||||
name words
|
||||
main help
|
||||
source-loaded? docs-loaded? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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: ? = ]
|
||||
|
|
@ -164,6 +91,14 @@ DEFER: 'rhs'
|
|||
#! 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
|
||||
#! non-terminal but must not be followed by 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,17 +156,37 @@ 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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
(:) [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel random math new-slots accessors ;
|
||||
USING: kernel random math accessors ;
|
||||
IN: random.dummy
|
||||
|
||||
TUPLE: random-dummy i ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue